Otherware/Otherware_1_SB_Development.iso/mac/developm/language/harvest.cpt/Harvest C/Tcl 6.2/tclMac.c

C/C++ Source or Header | 1992-04-28 | 90.9 KB | 3,543 lines

/*
 * Copyright 1992 Tim Endres
 *
 * Permission to use, copy, modify, and distribute this
 * software and its documentation for any purpose and without
 * fee is hereby granted, provided that the above copyright
 * notice appear in all copies. Tim Endres makes no representations
 * about the suitability of this software for any purpose.
 * It is provided "as is" without express or implied warranty.
 */

/* The following comments by Eric Sink

    What I have done is attempt to isolate the tcl port, and document
    what needs to be done in order to integrate tcl into an app.  The way
    I actually did this was to take the tcl code from Tim Endres' tickle,
    and integrate it into Harvest C.  Along the way, I've filled in the
    missing pieces, made the necessary modifications for THINK C, and
    tried to find the places where app specific customizations are
    required.  I have attempted to document these in the code.

    Rather than completely remove all application-specific code, I have
    left it all in, and attempted to document it.  In this way, what
    remains will serve as an example.  Generally, application specific
    code is accompanied by a comment explaining its purpose, and what you
    must do to replace it.  The comment will include the word CUSTOM, for
    easy searching.

    This version of tcl 6.2 contains many extensions specifically for the
    Macintosh.  Some of these extension bring up dialog boxes, and those
    dialog boxes are stored in resources.  You must integrate the macTcl
    resource file into your application as well.

    To support Tcl in your application means that your app may be controlled
    through tcl scripts.  You will install the tcl interpreter into your app,
    including this file.  You will probably want to provide a number of extensions
    to the Tcl language which are specific to your application.  Don't put them
    in this file.

    When you create a Tcl interpreter, you must initialize it to include all
    the Mac extensions contained here, as well as your own extensions.  My code,
    which appears elsewhere, looks like this :

    myInterp = Tcl_CreateInterp();     base Tcl routine
    Tcl_InitMacintosh(myInterp);     defined herein - install Mac extensions
    InitHarvestTcl(myInterp);         CUSTOM replace with your own app's inittcl
    init_environment();                 defined herein - initialize env variables

    Then you must provide an interface to Tcl, actually more than one.
    You must provide support for the 'misc' 'dosc' AppleEvent.  Code to handle
    this appears below.  This will allow your app to communicate with others
    applications which support tcl.

    You will also want to provide some form of user interface, to allow the user
    to enter tcl commands and run scripts.  In Harvest C, I provide a shell window,
    much like MPW (and like tickle for that matter).  The source code to this
    interface is included in this distribution (you must use the THINK Class
    Library with THINK C in order to use it).

    You must provide a place to put Feedback, stdout/stderr, and user input.
    Each application may wish to handle these in its own way.

*/

#pragma segment TCL

#include <stdlib.h>
#include <AppleEvents.h>
#include <Aliases.h>
#include "tcl.h"
#include <time.h>
#include "XTCL.h"

/* The following include files are application specific for Harvest C.
    You will need to delete these, and you will probably need to somehow
    declare the interfaces to your application. CUSTOM
*/
#include "CHarvestApp.h"
#include "CTclShell.h"

extern int errno;
extern int macintoshErr;
extern Str255 MyVersion;

int WDDirID(short);
int WDVolRef(short);

extern CHarvestApp *gApplication;    /* Harvest C specific declaration CUSTOM */

char *custom_name        = "tcl";
char *custom_longname    = "Harvest C";    /* change to your own app CUSTOM */
int   patchlevel        = 0;
char *tcl_defaultfile    = "tcl_default";
char *tcl_version        = "6.2";


#define SFSaveDisk        (* (short *) 0x0214)
#define CurDirStore        (* (long *)  0x0398)

#ifdef THINK_C
char *pathname();
char *fullname();
char *dirpathname();
typedef int (*PFI)();
#include <stdio.h>
#include <string.h>
#include <Packages.h>

/* CUSTOM You should define a function called UniversalFilter which is the
standard filter proc for your app.  NULL works fine for me, but you might
not think so. */

#define UniversalFilter NULL

/* CUSTOM Your application must provide some way for Tcl to send feedback
    messages to the user.  Harvest C provides a Tcl shell window where all
    user input is entered.  Feedback messages are sent to this window as well.
    At various places in the code below, Tcl may call Feedback().  The
    arguments to Feedback() are of the printf genre.  You must provide
    a substitute routine.  Since I use the THINK Class Library,
    my solution is to implement a method called Hprintf
    in my CTclShell object, defining this to be FeedBack.
*/

extern CTclShell *gShell;
#define Feedback gShell->Hprintf

/* CUSTOM These two variables must be initialized when your program
        starts up.  The idea is to set app_ref num equal to the
        reference number of the application resource file.  xtcl_refnum
        is the reference number of a file of XTCL resources which
        are available to the application.  I insert the following line
        in my program startup code :

            app_refnum = xtcl_refnum = CurResFile();
*/

short app_refnum;
short xtcl_refnum;

OSType def_text_file_creator = 'ALFA';    /* CUSTOM change this to whatever you want */

/* The following two variables appear to be necessary but I do not fully understand
    their function or use.  Tim ? */

unsigned long g_cron_interval;
unsigned long g_next_cron_time;

/* CUSTOM Change the following two lines if you want to customize the cursors
    management. */
#define UInitCursor InitCursor
#define WatchCursorOn() SetCursor(*GetCursor(watchCursor))

#define    MFOSEvent                    app4Evt    /* event used by MultiFinder */
#define    MFSuspendResumeMessage        1        /* high byte of suspend/resume event message */
#define    MFResumeMask                1        /* bit of message field for resume vs. suspend */
#define    MFMouseMovedMessage            0xFA    /* high byte of mouse-moved event message */

#define keyStdOutObject                'StdO'

#endif

extern int            tcl_handle_output();

Handle                tcl_Houtput_sethdl();
extern PFI            Tcl_SetPrintProcedure();
extern PFI            Tcl_GetPrintProcedure();

FrameButton(mydialog, button)
DialogPtr       mydialog;
short                   button;
{
short   myoval, mytype;
Handle  myhandle;
Rect    myrect;
char    mypat[8];

        PenNormal();
        PenSize(3, 3);
        *((long *)&mypat[0]) = (long)'\245\132\245\132';
        *((long *)&mypat[4]) = (long)'\245\132\245\132';
        GetDItem(mydialog, button, &mytype, &myhandle, &myrect);
        if (myhandle != NULL) {
                if ((**((ControlHandle)myhandle)).contrlHilite == 255)
                        PenPat(qd.gray);
                myoval = (myrect.bottom - myrect.top) * 4 / 5;
                InsetRect(&myrect, -4, -4);
                FrameRoundRect(&myrect, myoval, myoval);
                }
        PenNormal();
        }

MySetText(DialogPtr mydialog,int myItem,char            * myText)
{
short   item;
Rect    myrect;
Handle  myhandle;

        c2pstr(myText);
        GetDItem(mydialog, myItem, &item, &myhandle, &myrect);
        SetIText(myhandle, myText);
        p2cstr(myText);
        }

MyGetText(mydialog, myItem, myText)
DialogPtr       mydialog;
short           myItem;
char            *myText;
{
short   item;
Rect    myrect;
Handle  myhandle;

        GetDItem(mydialog, myItem, &item, &myhandle, &myrect);
        GetIText(myhandle, myText);
        p2cstr(myText);
        }

MyHiliteControl(mydialog, myItem, state)
DialogPtr       mydialog;
int                     myItem;
int                     state;
{
short           item;
Rect            myrect;
Handle          myhandle;

        GetDItem(mydialog, myItem, &item, &myhandle, &myrect);
        HiliteControl((ControlHandle)myhandle, state);
        }

MySetControl(mydialog, myItem, myValue)
DialogPtr       mydialog;
int                     myItem;
int                     myValue;
{
short           item;
Rect            myrect;
Handle          myhandle;

        GetDItem(mydialog, myItem, &item, &myhandle, &myrect);
        SetCtlValue((ControlHandle)myhandle, myValue);
        }

int MyGetControl(mydialog, myItem)
DialogPtr       mydialog;
int                     myItem;
{
short           item;
Rect            myrect;
Handle          myhandle;

        GetDItem(mydialog, myItem, &item, &myhandle, &myrect);
        return GetCtlValue((ControlHandle)myhandle);
        }

MySetTitle(mydialog, myItem, myTitle)
DialogPtr       mydialog;
int                     myItem;
char            *myTitle;
{
short           item;
Rect            myrect;
Handle  myhandle;
        GetDItem(mydialog, myItem, &item, &myhandle, &myrect);
        c2pstr(myTitle);
        SetCTitle((ControlHandle)myhandle, myTitle);
        p2cstr(myTitle);
        }

MyGetTitle(mydialog, myItem, myTitle)
DialogPtr       mydialog;
int                     myItem;
char            *myTitle;
{
short           item;
Rect            myrect;
Handle          myhandle;

        GetDItem(mydialog, myItem, &item, &myhandle, &myrect);
        GetCTitle((ControlHandle)myhandle, myTitle);
        p2cstr(myTitle);
        }


tcl_feedback_output(str)
char    *str;
{
    Feedback("%.240s", str);
    }

tcl_dev_null_output(str)
char    *str;
{
#pragma unused (str)

    }

/* CUSTOM Your application must support the notion of stdout for use with the
    puts command.  You must define the following routine to accept a string
    argument, and print it to your application's notion of stdout.  I handle
    this the same way I do Feedback, by dumping it to the shell window.
*/

tcl_print_tclshell(str)
char *str;
{
    gShell->Hprintf("%s",str);
}

run_DoScript(script_handle, result_handle, stdout_handle)
Handle        script_handle;
Handle        result_handle;
Handle        stdout_handle;
{
int            result;
int            delete_interp = 0;
PFI            saveproc;
Handle        myhandle = NULL;
char        command[128];
Tcl_Interp    *interp;

    WatchCursorOn();

    /* create a Tcl interpreter for the session */
    interp = (gShell->myInterp);

    saveproc = Tcl_SetPrintProcedure(tcl_dev_null_output);
    sprintf(command, "set AEVENT 1\n");
    result = Tcl_Eval(interp, command, 0, (char **)0);
    if (result != TCL_OK)
        Feedback("ERROR %d on <%s>", result, command);
    Tcl_SetPrintProcedure(saveproc);

    result = Tcl_Interp_Handle(interp, script_handle, result_handle, stdout_handle);
    if (result == TCL_OK)
        {
        result = noErr;
        }

    saveproc = Tcl_SetPrintProcedure(tcl_dev_null_output);
    sprintf(command, "set AEVENT 0\n");
    result = Tcl_Eval(interp, command, 0, (char **)0);
    Tcl_SetPrintProcedure(saveproc);

    UInitCursor();

    return result;
    }

run_AE_tcl_script(theFSS, result_handle, stdout_handle)
FSSpec        *theFSS;
Handle        result_handle;
Handle        stdout_handle;
{
int            result = noErr, wderr;
short        wdrefnum;
Handle        saveH, myhandle = NULL;
PFI            saveproc;
Tcl_Interp    *interp;
char        command[128];

    WatchCursorOn();

    /* create a Tcl interpreter for the session */
    interp = (gShell->myInterp);

    saveproc = Tcl_SetPrintProcedure(tcl_dev_null_output);
    sprintf(command, "set AEVENT 1\n");
    result = Tcl_Eval(interp, command, 0, (char **)0);
    if (result != TCL_OK)
        Feedback("ERROR %d on <%s>", result, command);

    wderr = OpenWD(theFSS->vRefNum, theFSS->parID, 'ERIK', &wdrefnum);
    if (wderr == noErr)
        SetVol(NULL, wdrefnum);
    else
        Feedback("Error %d OpenWD().", wderr);

    if (stdout_handle == NULL)
        {
        myhandle = NewHandle(0);
        if (myhandle == NULL)
            {
            Feedback("Error #%d allocating a stdout handle.", MemError());
            return -1770;
            }
        else
            saveH = tcl_Houtput_sethdl(myhandle);
        }
    else
        saveH = tcl_Houtput_sethdl(stdout_handle);

    Tcl_SetPrintProcedure(tcl_handle_output);

    sprintf(command, "source \"%.*s\"\n", theFSS->name[0], &theFSS->name[1]);
    result = Tcl_Eval(interp, command, 0, (char **)0);

    if (wderr == noErr)
        wderr = CloseWD(wdrefnum);

    if (result == TCL_OK)
        {
        result = noErr;
        if (result_handle != NULL)
            {
            tcl_Houtput_sethdl(result_handle);
            if (interp->result != NULL && *(interp->result) != '\0')
                (* Tcl_GetPrintProcedure()) (interp->result);
            }
        }
     else
        {
        result = -1771;
        (* Tcl_GetPrintProcedure()) ( (result == TCL_ERROR) ? "\015Error: " : "\015Bad Result: " );
        (* Tcl_GetPrintProcedure()) ( (interp->result == NULL) ? "<NULL>" : interp->result );
        }

    Tcl_SetPrintProcedure(tcl_dev_null_output);
    sprintf(command, "set AEVENT 0\n");
    Tcl_Eval(interp, command, 0, (char **)0);

    Tcl_SetPrintProcedure(saveproc);
    tcl_Houtput_sethdl(saveH);

    if (myhandle != NULL)
        DisposHandle(myhandle);

    UInitCursor();

    return result;
    }

run_named_tcl_script(filename, interp, print_proc)
char        *filename;    /* Pascal */
Tcl_Interp    *interp;
PFI            print_proc;
{
int            result = noErr;
int            delete_interp = 0;
PFI            saveproc;
char        command[128];

    WatchCursorOn();

    if (interp == (Tcl_Interp *)0) {
        interp = (gShell->myInterp);
        }

    if (print_proc != (PFI)0)
        saveproc = Tcl_SetPrintProcedure(print_proc);

    sprintf(command, "source \"%.*s\"\n", filename[0], &filename[1]);
    result = Tcl_Eval(interp, command, 0, (char **)0);

    if (result == TCL_OK)
        {
        result = noErr;
        if (interp->result != NULL && *(interp->result) != '\0')
            (* Tcl_GetPrintProcedure()) (interp->result);
        }
     else
        {
        (* Tcl_GetPrintProcedure()) ( (result == TCL_ERROR) ? "Error: " : "Bad Result: " );
        (* Tcl_GetPrintProcedure()) ( (interp->result == NULL) ? "<NULL>" : interp->result );
        }

    if (print_proc != (PFI)0)
        Tcl_SetPrintProcedure(saveproc);

    UInitCursor();

    return result;
    }


run_tcl_script(interp, print_proc)
Tcl_Interp    *interp;
PFI            print_proc;
{
int            result;
int            delete_interp = 0;
PFI            saveproc;
char        command[128];
Point        mypoint;
SFReply        myreply;
SFTypeList    mytypes;

    mypoint.h = mypoint.v = 75;
    mytypes[0] = 'TEXT';
    MyGetFile(mypoint, "\pScript:", NULL, (CheckOption()?-1:1), mytypes, NULL, &myreply);
    if (myreply.good) {

        WatchCursorOn();

        if (interp == (Tcl_Interp *)0) {
            interp = (gShell->myInterp);
            }

        if (print_proc != (PFI)0)
            saveproc = Tcl_SetPrintProcedure(print_proc);

        SetVol(NULL, myreply.vRefNum);
        sprintf(command, "source \"%.*s\"\n", myreply.fName[0], &myreply.fName[1]);

        result = Tcl_Eval(interp, command, 0, (char **)0);

        if (result == TCL_OK)
            {
            if (interp->result != NULL && *(interp->result) != '\0')
                (* Tcl_GetPrintProcedure()) (interp->result);
            }
         else
            {
            (* Tcl_GetPrintProcedure()) ( (result == TCL_ERROR) ? "Error: " : "Bad Result: " );
            (* Tcl_GetPrintProcedure()) ( (interp->result == NULL) ? "<NULL>" : interp->result );
            }

        if (print_proc != (PFI)0)
            Tcl_SetPrintProcedure(saveproc);

        UInitCursor();
        }

    }


int
Cmd_DoAlertNote(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
int        i;
char    format_str[32];
#pragma unused (clientData)

    if (argc > 6)
        {
        Tcl_AppendResult(interp, "too many arguments, limit 5", (char *) NULL);
        return TCL_ERROR;
        }

    format_str[0] = '\0';
    for (i=1; i<6 && i<argc; i++)
        strcat(format_str, "%s ");

    message_note(format_str, argv[1], argv[2], argv[3], argv[4], argv[5]);

    return TCL_OK;
    }

int
Cmd_Feedback(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
int        i;
char    output[256];
#pragma unused (interp, clientData, argc)

    output[0] = '\0';
    for (i = 1 ; i < argc && (strlen(output) + strlen(argv[i]) + 2) < 240 ; ++i) {
        strcat(output, argv[i]);
        strcat(output, " ");
        }

    Feedback("%.240s", output);

    return TCL_OK;
    }

static short        _current_working_directory = 0;
static short        _current_working_vrefnum = 0;
static long            _current_working_dirid = 2;

/* Note that two versions of the cd command are presented here.  I am using
the latter one, since I could not get Tim Endres' version working under THINK C.
The latter code was written by Pete Keleher.
*/

int
Cmd_DoCD(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
#ifdef ENDRES
int            myerr;
char        path[256], *ptr;
HParamBlockRec    pb;
WDPBRec        wpb;
CInfoPBRec    cpb;
#pragma unused (clientData)

    if (argc != 2)
        {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " dirName\"", (char *) NULL);
        return TCL_ERROR;
        }

    strcpy(path, argv[1]);
    ptr = strchr(path, ':');
    if (path[0] != ':' && ptr != NULL)
        {
        *(ptr + 1) = '\0';
        c2pstr(path);
        pb.volumeParam.ioCompletion = 0;
        pb.volumeParam.ioVRefNum = 0;
        pb.volumeParam.ioNamePtr = (unsigned char *) path;
        pb.volumeParam.ioVolIndex = -1;
        myerr = PBHGetVInfo(&pb, FALSE);
        if (myerr != noErr) {
            macintoshErr = myerr;
            Tcl_AppendResult(interp, "\"", argv[0], "\" PBHGetVInfo(", argv[1], ") ",
                                    Tcl_MacError(interp), (char *) NULL);
            return TCL_ERROR;
            }
        wpb.ioWDVRefNum = pb.volumeParam.ioVRefNum;
        wpb.ioWDDirID = 2;
        }
    else
        {
        path[0] = '\0';
        wpb.ioCompletion = 0;
        myerr = PBHGetVol(&wpb, FALSE);
        if (myerr != noErr) {
            macintoshErr = myerr;
            Tcl_AppendResult(interp, "\"", argv[0], "\" PBHGetVolInfo(", argv[1], ") ",
                                    Tcl_MacError(interp), (char *) NULL);
            return TCL_ERROR;
            }
        }

    strcpy(path, argv[1]);
    c2pstr(path);
    cpb.hFileInfo.ioCompletion = 0;                /* Synchronous */
    cpb.hFileInfo.ioNamePtr = (unsigned char *) path;
    cpb.hFileInfo.ioVRefNum = wpb.ioWDVRefNum;    /* Returned here */
    cpb.hFileInfo.ioFDirIndex = 0;                /* Use ioDirID and ioNamePtr */
    cpb.hFileInfo.ioDirID = wpb.ioWDDirID;        /* same offset as ioFlNum */
    myerr = PBGetCatInfo(&cpb, (Boolean)0);        /* Synchronous */
    if (myerr != noErr) {
        macintoshErr = myerr;
        Tcl_AppendResult(interp, "\"", argv[0], "\" PBGetCatInfo(", argv[1], ") ",
                                Tcl_MacError(interp), (char *) NULL);
        return TCL_ERROR;
        }
    else if ((cpb.hFileInfo.ioFlAttrib & ioDirMask) == 0) {
        Tcl_AppendResult(interp, "\"", argv[1], "\" not a directory", (char *) NULL);
        return TCL_ERROR;
        }
    else {
        wpb.ioCompletion = 0;
        wpb.ioVRefNum = wpb.ioWDVRefNum;
        wpb.ioNamePtr = (unsigned char *) NULL;
        wpb.ioWDDirID = cpb.hFileInfo.ioDirID;
        myerr = PBHSetVol(&wpb, FALSE);
        if (myerr != noErr) {
            macintoshErr = myerr;
            Tcl_AppendResult(interp, "\"", argv[0], "\" PBHSetVol() ",
                                    Tcl_MacError(interp), (char *) NULL);
            return TCL_ERROR;
            }
        else {
            wpb.ioWDProcID = 'ERIK';
            myerr = PBOpenWD(&wpb, FALSE);
            if (myerr == noErr) {
                _current_working_directory = wpb.ioVRefNum;
                _current_working_vrefnum = wpb.ioWDVRefNum;
                _current_working_dirid = cpb.hFileInfo.ioDirID;
                }
            else {
                macintoshErr = myerr;
                Tcl_AppendResult(interp, "\"", argv[0], "\" PBOpenWD() ",
                                        Tcl_MacError(interp), (char *) NULL);
                return TCL_ERROR;
                }
            }
        }

    return TCL_OK;
#else
    char            temp[256], *ptr;
    FSSpec            spec;
    Boolean            folder, aliased;
    WDPBRec            param;
    int                ups, i;

    if (argc > 2)
    {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                    " dirName\"", (char *) NULL);
        return TCL_ERROR;
    }

/* Note that one could support home directories by simply querying an
    environment variable called HOME
*/
    if (argc == 1)
    {
        Tcl_SetResult(interp, "ERROR: No home directories on the Mac\r", TCL_STATIC);
        return TCL_ERROR;
    }

    // Use the spec to resolve '::' tangles.
    strcpy(temp, argv[1]);
    if (!(*temp)) {
        Tcl_SetResult(interp, "ERROR: No home directories on the Mac\r", TCL_STATIC);
        return TCL_ERROR;
    }
    CtoPstr(temp);

  setVol:
    if (FSMakeFSSpec(0, 0, temp, &spec) ||
        ResolveAliasFile(&spec, TRUE, &folder, &aliased))
    {
        Tcl_SetResult(interp, "ERROR: Invalid directory\r", TCL_STATIC);
        return TCL_ERROR;
    }
    param.ioCompletion = NULL;
    param.ioNamePtr = spec.name;
    param.ioVRefNum = spec.vRefNum;
    param.ioWDDirID = spec.parID;
    param.ioWDProcID = 'ERIK';
    if (PBOpenWD(¶m, FALSE))
    {
        Tcl_SetResult(interp, "Not a directory", TCL_STATIC);
        return TCL_ERROR;
    }
    if (SetVol("", param.ioVRefNum))
    {
        Tcl_SetResult(interp, "SetVol Failed", TCL_STATIC);
        return TCL_ERROR;
    }

    _current_working_directory = param.ioVRefNum;
    _current_working_vrefnum = param.ioWDVRefNum;
    _current_working_dirid = param.ioWDDirID;
    return TCL_OK;

#endif

    }

set_current_wd(vRefNum, dirID)
int        vRefNum;
long    dirID;
    {
    int            myerr;
    WDPBRec        wpb;

    wpb.ioCompletion = 0;
    wpb.ioVRefNum = vRefNum;
    wpb.ioNamePtr = (unsigned char *) NULL;
    wpb.ioWDDirID = dirID;
    myerr = PBHSetVol(&wpb, FALSE);
    if (myerr != noErr) {
        return myerr;
        }
    else {
        wpb.ioWDProcID = 'ERIK';
        myerr = PBOpenWD(&wpb, FALSE);
        if (myerr == noErr) {
            _current_working_directory = wpb.ioVRefNum;
            _current_working_vrefnum = wpb.ioWDVRefNum;
            _current_working_dirid = dirID;
            }
        else {
            return myerr;
            }
        }
    }

int
current_wd()
{
    return _current_working_directory;
    }

int
current_vrefnum()
{
    return _current_working_vrefnum;
    }

int
current_dirid()
{
    return _current_working_dirid;
    }

int
Cmd_DoPWD(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
char    path[256];
#pragma unused (clientData, argc, argv)

/* Note, the #ifdeffed out version of this command is Tim's original code.
    I've replaced it with my own, which may be no better.  Basically, one
    of the more troublesome parts of porting Tim's code to THINK C was
    the issue of pathnames.  They just didn't seem to work right, so I
    substituted pieces until they did.  Tim's code works fine for him though.
*/

#ifdef Undefined
    GetPathName(path,NULL,current_vrefnum(),current_dirid());
    p2cstr(path);

    Tcl_SetResult(interp, path, TCL_VOLATILE);

    return TCL_OK;
#else
    pathname(path, current_wd());

    Tcl_SetResult(interp, path, TCL_VOLATILE);

    return TCL_OK;
#endif
    }

int
Cmd_GetDirectory(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{


char    path[256];
short    vRefNum;
long    dirID;
#pragma unused (clientData)

    SFSaveDisk = current_vrefnum() * -1;
    CurDirStore = current_dirid();

    path[0] = '\0';
    if (! GetFolderPathName( ((argc == 2) ? argv[1] : "Directory..."), path, &vRefNum, &dirID ) )
        Tcl_SetResult(interp, "", TCL_VOLATILE);
    else {
        Tcl_SetResult(interp, path, TCL_VOLATILE);
        }

    return TCL_OK;

    }

int
Cmd_GetFile(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{


char    path[256], prompt[256], *ptr, *ptr2;
int        i, j;
Point    mypoint;
SFReply    myreply;
SFTypeList mytypes;
#pragma unused (clientData, argc, argv)

    path[0] = '\0';
    i = -1;
    if (argc > 1) {
        strcpy(prompt, argv[1]);
        c2pstr(prompt);
        }
    if (argc > 2) {
        for (ptr=argv[2],i=0 ; i < 4 && *ptr ; i++) {
            ptr2 = (char *) &mytypes[i];
            for (j=0; j<4; j++) {
                *ptr2++ = (*ptr) ? *ptr++ : ' ';
                }
            }
        if (i == 0)
            i = -1;
        }

    mypoint.h = mypoint.v = 75;

    SFSaveDisk = current_vrefnum() * -1;
    CurDirStore = current_dirid();

    MyGetFile(mypoint, prompt, NULL, i, mytypes, NULL, &myreply);
    if (myreply.good) {
        p2cstr(myreply.fName);
        fullname(path, myreply.vRefNum, myreply.fName);
        Tcl_SetResult(interp, path, TCL_VOLATILE);
        }
    else {
        Tcl_SetResult(interp, "", TCL_VOLATILE);
        }

    return TCL_OK;

    }

int
Cmd_PutFile(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{


char    path[256], prompt[256], original[128];
int        i;
Point    mypoint;
SFReply    myreply;
#pragma unused (clientData, argc, argv)

    path[0] = '\0';
    original[0] = '\0';
    i = -1;
    if (argc > 1) {
        strcpy(prompt, argv[1]);
        c2pstr(prompt);
        }
    if (argc > 2) {
        strcpy(original, argv[2]);
        c2pstr(original);
        }

    mypoint.h = mypoint.v = 75;
    SFSaveDisk = current_vrefnum() * -1;
    CurDirStore = current_dirid();
    MyPutFile(mypoint, prompt, original, NULL, &myreply);
    if (myreply.good) {
        p2cstr(myreply.fName);
        fullname(path, myreply.vRefNum, myreply.fName);
        Tcl_SetResult(interp, path, TCL_VOLATILE);
        }
    else {
        Tcl_SetResult(interp, "", TCL_VOLATILE);
        }

    return TCL_OK;

    }

space_cnt(str)
char    *str;
{
int        count;

    for (count=0 ; *str ; str++)
        if (*str == ' ')
            count++;

    return count;
    }

int
Cmd_EscapeSpaces(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
int        i, length;
char    *save, *ptr, *ptr2;
#pragma unused (clientData)

    if (argc < 2) {
        Tcl_SetResult(interp, "", TCL_VOLATILE);
        return TCL_OK;
        }

    for (length = 0, i = 1 ; i < argc ; i++) {
        length += strlen(argv[i]) + 2;    /* 2 for "\ " */
        length += ( 2 * space_cnt(argv[i]) );
        }
    length += 8;    /* terminator + */

    save = ptr = malloc(length);
    if (ptr == NULL) {
        Tcl_AppendResult(interp, "\"", argv[0], "\" out of memory", (char *) NULL);
        return TCL_ERROR;
        }
    else {
        for (length = 0, i = 1 ; i < argc ; i++) {
            if (i > 1) {
                *ptr++ = '\\';
                *ptr++ = ' ';
                }
            for (ptr2 = argv[i] ; *ptr2 ; ) {
                if (*ptr2 == ' ' && ptr2 > argv[i] && *(ptr2-1) != '\\')
                    *ptr++ = '\\';
                *ptr++ = *ptr2++;
                }
            }

        *ptr = '\0';
        Tcl_SetResult(interp, save, TCL_VOLATILE);
        free(save);
        }

    return TCL_OK;
    }

int
Cmd_DoGetenv(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
char    *ptr;
extern char * tcl_getenv(char *name);

#pragma unused (clientData)

    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " variable_name\"", (char *) NULL);
        return TCL_ERROR;
        }
    else {
        ptr = tcl_getenv(argv[1]);
#ifdef NEVER_DEFINED
        ptr = get_environment(argv[1]);
#endif
        if (ptr != NULL)
            Tcl_SetResult(interp, ptr, TCL_VOLATILE);
        else
            Tcl_SetResult(interp, "", TCL_VOLATILE);
        return TCL_OK;
        }
    }

int
Cmd_DoPutenv(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
#pragma unused (clientData)

    if (argc != 3) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " name value\"", (char *) NULL);
        return TCL_ERROR;
        }
    else {
        tcl_setenv(argv[1], argv[2]);
        Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
        return TCL_OK;
        }
    }

int
Cmd_CTime(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
char    *ptr;
#ifdef THINK_C
time_t seconds;
#else
unsigned long seconds;
#endif
#pragma unused (clientData)

    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " time\"", (char *) NULL);
        return TCL_ERROR;
        }
    else {
        char *end;
        seconds = strtoul(argv[1],&end,10);    /* Tim, I changed this - Eric */
        ptr = (char *) ctime(&seconds);
        ptr[strlen(ptr)-1] = '\0';    /* Drop \n */
        Tcl_SetResult(interp, ptr, TCL_VOLATILE);
        return TCL_OK;
        }
    }

int
Cmd_MacDateTime(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
char            datestr[64], timestr[64];
unsigned long    now;
#pragma unused (clientData)

    if (argc < 2 || argc > 3) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " time ?format?\" where format is \"long, short, or abbrev\"", (char *) NULL);
        return TCL_ERROR;
        }
    else {
        if (sscanf(argv[1], "%lu", &now) != 1)
            {
            Tcl_AppendResult(interp, "invalid time \"", argv[1], "\"", (char *) NULL);
            return TCL_ERROR;
            }
        else
            {
            IUDateString(now, (argc == 2 ? shortDate :
                               (argv[2][0] == 's' ? shortDate :
                                (argv[2][0] == 'l' ? longDate : abbrevDate) ) ), (unsigned char *) datestr);
            IUTimeString(now, TRUE, (unsigned char *) timestr);
            p2cstr(datestr);
            p2cstr(timestr);
            Tcl_AppendResult(interp, datestr, " ", timestr, (char *) NULL);
            return TCL_OK;
            }
        }
    }

int
Cmd_Ticks(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
char    tickstr[64];
#pragma unused (clientData, argv)

    if (argc != 1) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], "\"", (char *) NULL);
        return TCL_ERROR;
        }
    else {
        sprintf(tickstr, "%lu", TickCount());
        Tcl_SetResult(interp, tickstr, TCL_VOLATILE);
        return TCL_OK;
        }
    }

int
Cmd_Now(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
unsigned long now;
char    nowstr[64];
#pragma unused (clientData, argv)

    if (argc != 1) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], "\"", (char *) NULL);
        return TCL_ERROR;
        }
    else {
        GetDateTime(&now);
        sprintf(nowstr, "%lu", now);
        Tcl_SetResult(interp, nowstr, TCL_VOLATILE);
        return TCL_OK;
        }
    }

int
Cmd_AskYesNoCancel(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
int            result;
#pragma unused (clientData, argc)

    UInitCursor();
    c2pstr(argv[1]);
    ParamText(argv[1], NULL, NULL, NULL);
    result = Alert(1015, (ModalFilterProcPtr)/*0*/UniversalFilter);
    p2cstr(argv[1]);
    if (result == 1) {
        Tcl_SetResult(interp, "yes", TCL_VOLATILE);
        }
    else if (result == 2) {
        Tcl_SetResult(interp, "no", TCL_VOLATILE);
        }
    else if (result == 3) {
        Tcl_SetResult(interp, "cancel", TCL_VOLATILE);
        }
    return TCL_OK;
    }

int
Cmd_GetInputLine(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
DialogPtr    myDialog;
short        itemhit;
char        mystr[256];
#pragma unused (clientData, argc)

    UInitCursor();
    myDialog = GetNewDialog(2007, NULL, (WindowPtr)-1);
    if (myDialog == NULL) {
        Tcl_AppendResult(interp, "\"", argv[0], "\" can not load dialog 2007", (char *) NULL);
        return TCL_ERROR;
        }

    if (argc > 1)
        MySetText(myDialog, 3, argv[1]);

    if (argc > 2) {
        MySetText(myDialog, 4, argv[2]);
        SelIText(myDialog, 4, 0, 1023);
        }

    for ( ; ; ) {
        SetPort(myDialog);
        FrameButton(myDialog, ok);
        ModalDialog((ModalFilterProcPtr)/*0*/UniversalFilter, &itemhit);
        if (itemhit == ok) {
            MyGetText(myDialog, 4, mystr);
            Tcl_SetResult(interp, mystr, TCL_VOLATILE);
            break;
            }
        else if (itemhit == cancel) {
            Tcl_SetResult(interp, "", TCL_VOLATILE);
            break;
            }
        }

    CloseDialog(myDialog);
    return TCL_OK;
    }

int
Cmd_GetFileInfo(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
char    buffer1[64];
char    buffer2[64];
char    buffer3[64];
char    buffer4[64];
char    pascal_name[256];
DateTimeRec    cdate, mdate;
ParamBlockRec    pb;
#pragma unused (clientData, argc)

    strcpy(pascal_name, argv[1]);
    c2pstr(pascal_name);

    pb.fileParam.ioCompletion = 0;
    pb.fileParam.ioVRefNum = current_wd();
    pb.fileParam.ioNamePtr = (unsigned char *) pascal_name;
    pb.fileParam.ioFDirIndex = 0;
    pb.fileParam.ioFVersNum = 0;
    PBGetFInfo(&pb, FALSE);
    if (pb.fileParam.ioResult != noErr) {
        char    msg[64];

        sprintf(msg, "error #%d in PBGetInfo(%.32s)", pb.fileParam.ioResult, argv[1]);
        Tcl_AppendResult(interp, "\"", argv[0], "\" ", msg, (char *) NULL);
        return TCL_ERROR;
        }
    else {
        Secs2Date(pb.fileParam.ioFlCrDat, &cdate);
        Secs2Date(pb.fileParam.ioFlMdDat, &mdate);
        sprintf(buffer1, "'%4.4s' '%4.4s' %c%c%c%c%c%c%c",
                    &pb.fileParam.ioFlFndrInfo.fdCreator, &pb.fileParam.ioFlFndrInfo.fdType,
                    ( ((pb.fileParam.ioFlFndrInfo.fdFlags&0x8000)!=0)        ? 'L' : 'l' ),
                    ( ((pb.fileParam.ioFlFndrInfo.fdFlags&fInvisible)!=0)    ? 'V' : 'v' ),
                    ( ((pb.fileParam.ioFlFndrInfo.fdFlags&fHasBundle)!=0)    ? 'B' : 'b' ),
                    ( ((pb.fileParam.ioFlFndrInfo.fdFlags&0x1000)!=0)        ? 'S' : 's' ),
                    ( ((pb.fileParam.ioFlFndrInfo.fdFlags&0x0100)!=0)        ? 'I' : 'i' ),
                    ( ((pb.fileParam.ioFlFndrInfo.fdFlags&fOnDesk)!=0)        ? 'D' : 'd' ),
                    ( ((pb.fileParam.ioFlFndrInfo.fdFlags&0x0080)!=0)        ? 'M' : 'm' )
                    );
        sprintf(buffer2, "%02d/%02d/%02d %02d:%02d:%02d",
                    cdate.month, cdate.day, cdate.year%100, cdate.hour, cdate.minute, cdate.second
                    );
        sprintf(buffer3, "%02d/%02d/%02d %02d:%02d:%02d",
                    mdate.month, mdate.day, mdate.year%100, mdate.hour, mdate.minute, mdate.second
                    );
        sprintf(buffer4, "%d,%d %ld %ld",
                    pb.fileParam.ioFlFndrInfo.fdLocation.h,
                    pb.fileParam.ioFlFndrInfo.fdLocation.v,
                    pb.fileParam.ioFlLgLen, pb.fileParam.ioFlRLgLen
                    );

        sprintf(pascal_name, "%s %s %s %s", buffer1, buffer2, buffer3, buffer4);
        Tcl_SetResult(interp, pascal_name, TCL_VOLATILE);

        return TCL_OK;
        }
    }

int
Cmd_SetFileInfo(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
char    *ptr;
int        i, j;
char    pascal_name[256];
ParamBlockRec    pb;
#pragma unused (clientData)

    strcpy(pascal_name, argv[1]);
    c2pstr(pascal_name);

    pb.fileParam.ioCompletion = 0;
    pb.fileParam.ioVRefNum = current_wd();
    pb.fileParam.ioNamePtr = (unsigned char *) pascal_name;
    pb.fileParam.ioFDirIndex = 0;
    pb.fileParam.ioFVersNum = 0;
    PBGetFInfo(&pb, FALSE);
    if (pb.fileParam.ioResult != noErr) {
        char    msg[64];

        sprintf(msg, "error #%d in PBGetInfo(%.32s)", pb.fileParam.ioResult, argv[1]);
        Tcl_AppendResult(interp, "\"", argv[0], "\" ", msg, (char *) NULL);
        return TCL_ERROR;
        }
    else {
        for (i = 2 ; i < argc ; i+=2) {
            if (argv[i][0] == '-') {
                switch (argv[i][1]) {
                    case 'a':    /* attributes (lowercase = 0, uppercase = 1) [*] */
                        ptr = argv[i+1];
                        for (ptr = argv[i+1] ; *ptr ; ptr++) {
                            switch (*ptr) {
                                case 'L': case 'l':    /* Locked / Not */
                                    if (*ptr == 'L')
                                        pb.fileParam.ioFlFndrInfo.fdFlags |= 0x8000;
                                    else
                                        pb.fileParam.ioFlFndrInfo.fdFlags &= ~0x8000;
                                    break;
                                case 'V': case 'v':    /* Invisible / Visible */
                                    if (*ptr == 'V')
                                        pb.fileParam.ioFlFndrInfo.fdFlags |= fInvisible;
                                    else
                                        pb.fileParam.ioFlFndrInfo.fdFlags &= ~fInvisible;
                                    break;
                                case 'B': case 'b':    /* Bundled / Not */
                                    if (*ptr == 'B')
                                        pb.fileParam.ioFlFndrInfo.fdFlags |= fHasBundle;
                                    else
                                        pb.fileParam.ioFlFndrInfo.fdFlags &= ~fHasBundle;
                                    break;
                                case 'S': case 's':    /* System / Not */
                                    if (*ptr == 'S')
                                        pb.fileParam.ioFlFndrInfo.fdFlags |= 0x1000;
                                    else
                                        pb.fileParam.ioFlFndrInfo.fdFlags &= ~0x1000;
                                    break;
                                case 'I': case 'i':    /* Inited / Not */
                                    if (*ptr == 'I')
                                        pb.fileParam.ioFlFndrInfo.fdFlags |= 0x0100;
                                    else
                                        pb.fileParam.ioFlFndrInfo.fdFlags &= ~0x0100;
                                    break;
                                case 'D': case 'd':    /* 0x0001 Desktop / Not */
                                    if (*ptr == 'D')
                                        pb.fileParam.ioFlFndrInfo.fdFlags |= fOnDesk;
                                    else
                                        pb.fileParam.ioFlFndrInfo.fdFlags &= ~fOnDesk;
                                    break;
                                case 'M': case 'm':    /* Sharable / Not */
                                    if (*ptr == 'M')
                                        pb.fileParam.ioFlFndrInfo.fdFlags |= 0x0080;
                                    else
                                        pb.fileParam.ioFlFndrInfo.fdFlags &= ~0x0080;
                                    break;
                                case 'Z': case 'z':    /* Always Switch / Do Not */
#ifdef NEVER_DEFINED
                                    if (*ptr == 'Z')
                                        pb.fileParam.ioFlFndrInfo.fdFlags |= fHasBundle;
                                    else
                                        pb.fileParam.ioFlFndrInfo.fdFlags &= ~fHasBundle;
#endif
                                    break;
                                }
                            }
                        break;
                    case 'c':    /* file creator */
                        ptr = (char *) &pb.fileParam.ioFlFndrInfo.fdCreator;
                        for (j = 0 ; argv[i+1][j] ; j++)
                            *ptr++ = argv[i+1][j];
                        for ( ; j < 4 ; j++)
                            *ptr++ = ' ';
                        break;
                    case 'd':    /* creation date (mm/dd/yy [hh:mm[:ss] [AM | PM]]) [*] */
                        break;
                    case 'l':    /* ICON location (horizontal,vertical) [*] */
                        break;
                    case 'm':    /* modification date (mm/dd/yy [hh:mm[:ss] [AM | PM]]) [*] */
                        break;
                    case 't':    /* file type */
                        ptr = (char *) &pb.fileParam.ioFlFndrInfo.fdType;
                        for (j = 0 ; argv[i+1][j] ; j++)
                            *ptr++ = argv[i+1][j];
                        for ( ; j < 4 ; j++)
                            *ptr++ = ' ';
                        break;
                    }
                }
            else {
                Tcl_AppendResult(interp, "\"", argv[0], "\" invalid option ",
                                        argv[1], (char *) NULL);
                return TCL_ERROR;
                }
            }

        PBSetFInfo(&pb, FALSE);
        if (pb.fileParam.ioResult != noErr) {
            char    msg[64];

            sprintf(msg, "error #%d in PBSetInfo(%.32s)", pb.fileParam.ioResult, argv[1]);
            Tcl_AppendResult(interp, "\"", argv[0], "\" ", msg, (char *) NULL);
            return TCL_ERROR;
            }
        }

    return TCL_OK;
    }

/* CUSTOM You must write your own application specific version of Cmd_TclMacYield.
    Tim's version is presented here.  I have ifdeffed it out in favor of a
    Harvest C-specific version.  You must provide something else.
*/

#ifdef TEMP_GONE
int
Cmd_TclMacYield(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
int                got_event;
short            emask, event_ticks;
WindowPtr        whichwindow;
#pragma unused (clientData, interp)

    /* emask = osMask | activMask | updateMask | mDownMask | keyDownMask; */
    emask = ( everyEvent & ~(autoKeyMask | keyDownMask) );
    /* emask = osMask | activMask | updateMask | mDownMask | keyDownMask; */

    event_ticks = 6;
    if (argc == 2)
        {
        event_ticks = atoi(argv[1]);
        }

    if (has_wait_next_event) {
        got_event =  WaitNextEvent(emask, &gEvent, event_ticks, (RgnHandle)0);
        }
    else {
        SystemTask();
        got_event = GetNextEvent(emask, &gEvent);
        }

    /*
    ** Has the user done something?
    */
    if (got_event) {

        switch (gEvent.what) {
            case mouseDown:
                switch (FindWindow(gEvent.where, &whichwindow)) {
                    case inMenuBar:
                        break;
                    case inDrag:
                        break;
                    case inGoAway:
                        break;
                    case inGrow:
                        break;
                    case inSysWindow:
                        SystemClick(&gEvent, whichwindow);
                        break;
                    case inContent:
                        break;
                    }
                gLastDown = gEvent.when;
                break;
            case activateEvt:
                wind_parse((WindowPtr) gEvent.message, &gEvent, wActivate);
                break;
            case updateEvt:
                wind_parse((WindowPtr) gEvent.message, &gEvent, wUpdate);
                break;
            case MFOSEvent:
                switch ((gEvent.message >> 24) & 0x00FF) {    /* high byte of message */
                    case MFSuspendResumeMessage:    /* suspend/resume is also an activate/deactivate */
                        in_back_ground = (gEvent.message & MFResumeMask) == 0;
                        if (! in_back_ground) {
                            /* RESUME */
                            TEFromScrap();
                            WatchCursorOn();
                            }
                        else {
                            /* SUSPEND */
                            UInitCursor();
                            }
                        break;
                    }
                break;
            default:
                break;
            }

        gLastEvent = gEvent;
        }

    return TCL_OK;
    }

#else
int
Cmd_TclMacYield(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
    gApplication->Process1Event();
}
#endif

int
XTCL_Eval_CallBack(cpb, script_handle, result_handle, stdout_handle)
XTCLParmBlk    *cpb;
Handle        script_handle;
Handle        result_handle;
Handle        stdout_handle;
{
    return Tcl_Interp_Handle(cpb->interp, script_handle, result_handle, stdout_handle);
    }

int
Cmd_CallExternalCMD(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
Handle        myhandle = NULL,
            result_handle = NULL;
int            result = TCL_OK;
short        saveref, the_refnum = -1, user_ref = -1;
char        name[256];
XTCLParmBlk    cbpb;
#pragma unused (clientData)

    saveref = CurResFile();
    if (argv[1][0] == '-' && argv[1][1] == 'f' && argv[1][2] == '\0') {
        c2pstr(argv[2]);
        SetVol(NULL, current_wd());
        user_ref = OpenResFile(argv[2]);
        p2cstr(argv[2]);
        if (user_ref == -1) {
            macintoshErr = ResError();
            Tcl_AppendResult(interp, "\"", argv[0], "\" OpenResfile(", argv[2], ") ",
                                    Tcl_MacError(interp), (char *) NULL);
            return TCL_ERROR;
            }
        else
            the_refnum = user_ref;

        strcpy(name, argv[3]);
        argc -= 3;
        argv += 3;
        }
    else {
        strcpy(name, argv[1]);
        argc--;
        argv++;
        }
    c2pstr(name);

    if (user_ref != -1) {
        UseResFile(user_ref);
        myhandle = GetNamedResource((ResType)'XTCL', name);
        }
    if (myhandle == NULL) {
        UseResFile(app_refnum);
        the_refnum = app_refnum;
        myhandle = GetNamedResource((ResType)'XTCL', name);
        if (myhandle == NULL && xtcl_refnum != -1) {
            UseResFile(xtcl_refnum);
            the_refnum = xtcl_refnum;
            myhandle = GetNamedResource((ResType)'XTCL', name);
            }
        }

    if (myhandle != NULL) {
        LoadResource(myhandle);
        DetachResource(myhandle);

        result_handle = NewHandle(1);
        if (result_handle != NULL) {
            **result_handle = '\0';

            cbpb.version = XTCL_CB_VERSION;
            cbpb.result = noErr;
            cbpb.resultH = result_handle;
            cbpb.interp = interp;
            cbpb.eval = XTCL_Eval_CallBack;
            cbpb.cmdRefNum = the_refnum;
            cbpb.cmdHandle = myhandle;
            cbpb.modalproc = UniversalFilter;

            UseResFile(the_refnum);
            /* CallXTCL(argc, argv, &cbpb, *myhandle); */

            HLock(myhandle);

            (((PFI) (*myhandle)) )(argc, argv, &cbpb);

            HUnlock(myhandle);

            UseResFile(saveref);

            if (*result_handle != NULL && **result_handle != '\0')
                {
                HLock(result_handle);
                Tcl_SetResult(interp, *result_handle, TCL_VOLATILE);
                HUnlock(result_handle);
                }

            DisposHandle(result_handle);

            result = cbpb.result;
            }
        else
            {
            char    msg[64];

            sprintf(msg, "error #%d getting result handle", MemError());
            Tcl_AppendResult(interp, "\"", argv[0], "\" ", msg, (char *) NULL);
            result = TCL_ERROR;
            }

        DisposHandle(myhandle);
        }
    else {
        char    msg[96];

        sprintf(msg, "error %d:%d:%d loading XTCL '%.*s'",
                ResError(), MemError(), xtcl_refnum, name[0], &name[1]);
        Tcl_AppendResult(interp, "\"", argv[0], "\" ", msg, (char *) NULL);
        if (user_ref != -1)
            CloseResFile(user_ref);
        result = TCL_ERROR;
        }

    if (user_ref != -1)
        CloseResFile(user_ref);

    UseResFile(saveref);
    return result;
    }

static ListHandle    picklist = NULL;
static char            string_reply[256];

#define SetCell(cell, row, column)    { (cell).h = column; (cell).v = row; }
#define ROW(cell)                     (cell).v

pascal void
MacListUpdate(myDialog, myItem)
DialogPtr        myDialog;
short            myItem;
{
Rect            myrect;
#pragma unused (myItem)

    LUpdate(myDialog->visRgn, picklist);
    myrect = (**(picklist)).rView;
    InsetRect(&myrect, -1, -1);
    FrameRect(&myrect);
    }

pascal Boolean
MacListFilter(myDialog, myEvent, myItem)
DialogPtr        myDialog;
EventRecord        *myEvent;
short            *myItem;
{
Rect    listrect;
short    myascii;
Handle    myhandle;
Point    mypoint;
short    mytype;

    SetPort(myDialog);
    if (myEvent->what == keyDown) {
        myascii = myEvent->message % 256;
        if (myascii == '\015' || myascii == '\003') {    /* This is return or enter... */
            *myItem = 1;
            return true;
            }
        }
    else if (myEvent->what == mouseDown) {
        mypoint = myEvent->where;
        GlobalToLocal(&mypoint);
        GetDItem(myDialog, 4, &mytype, &myhandle, &listrect);
        if (PtInRect(mypoint, &listrect) && picklist != NULL) {
            if (LClick(mypoint, (short)myEvent->modifiers, picklist)) {
                /* User double-clicked in cell... */
                *myItem = 1;
                return true;
                }
            }
        }
    else if (myEvent->what == updateEvt) {
    /* CUSTOM wind_parse is a tickle specific routine which sends an
        update or activate event to the current window.  You should
        provide a substitute for your application.  I have not done so,
        at least not yet.
    */
#ifdef Undefined
        wind_parse((WindowPtr) myEvent->message, myEvent, wUpdate);
#endif
        }
    else if (myEvent->what == activateEvt) {
        if (picklist != NULL && (WindowPtr)myEvent->message == myDialog)
            LActivate((Boolean)((myEvent->modifiers & 0x01) != 0), picklist);
#ifdef Undefined
        wind_parse((WindowPtr) myEvent->message, myEvent, wActivate);
#endif
        }

    return false;
    }



int
Cmd_MacListPick(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
short        itemhit, done, row, result, length;
DialogPtr    mydialog;
ListHandle    mylist;
Cell        mycell;
short        mytype;
Handle        myhandle;
Point        cellsize;
Rect        listrect, dbounds;
int            listArgc;
char        **listArgv;
#pragma unused (clientData)

    InitCursor();
    mydialog = GetNewDialog(3030, NULL, (WindowPtr)-1);
    if (mydialog == NULL) {
        Tcl_AppendResult(interp, "\"", argv[0], "\" can not load dialog 3030", (char *) NULL);
        return TCL_ERROR;
        }

    if (argv[1][0] == '-' && argv[1][1] == 'p' && argv[1][2] == '\0') {
        MySetText(mydialog, 3, argv[2]);
        argc -= 2;
        argv += 2;
        }
    else {
        MySetText(mydialog, 3, "Select:");
        }

    if (argc != 2)
        {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " ?-p prompt? itemList\"", (char *) NULL);
        return TCL_ERROR;
        }

    if (Tcl_SplitList (interp, argv[1], &listArgc, &listArgv) != TCL_OK)
        {
        return TCL_ERROR;
        }

    GetDItem(mydialog, 4, &mytype, &myhandle, &listrect);
    SetDItem(mydialog, 4, mytype, (Handle)MacListUpdate, &listrect);

    SetPort(mydialog);
    InsetRect(&listrect, 1, 1);
    SetRect(&dbounds, 0, 0, (short)1, (short)0);
    cellsize.h = (listrect.right - listrect.left);
    cellsize.v = 17;

    listrect.right -= 15;

    picklist = LNew(&listrect, &dbounds, cellsize, (short)0,
                            mydialog, true, false, (Boolean)0, (Boolean)1);
    if (picklist == NULL) {
        DisposDialog(mydialog);
        Tcl_AppendResult(interp, "\"", argv[0], "\" could not create dialog list", (char *) NULL);
        ckfree((char *) listArgv);
        return TCL_ERROR;
        }

    mylist = picklist;
    LDoDraw(FALSE, mylist);

    for (row=0 ; listArgc > 0 ; row++, listArgc--) {
        LAddRow(1, row, mylist);
        SetCell(mycell, (short)row, 0);
        LSetCell((Ptr)listArgv[row], (short)strlen(listArgv[row]), mycell, mylist);
        }

    ckfree((char *) listArgv);

    LDoDraw(TRUE, mylist);
    /* CenterWindow(mydialog); */
    ShowWindow(mydialog);

    for (done=0; ! done; )    {
        SetPort(mydialog);
        FrameButton(mydialog, ok);
        ModalDialog(MacListFilter, &itemhit);
        switch (itemhit) {
            case ok:
                SetCell(mycell, 0, 0);
                done = 1; result = 0;
                if (LGetSelect((short)true, &mycell, picklist)) {
                    length = 255;
                    LGetCell(string_reply, &length, mycell, picklist);
                    string_reply[length] = '\0';
                    result = 1;
                    }
                break;
            case cancel:
                done = 1; result = 0;
                break;
            }

        }    /* Modal Loop */

    if (result) {
        Tcl_SetResult(interp, string_reply, TCL_VOLATILE);
        }
    else {
        Tcl_SetResult(interp, "", TCL_VOLATILE);
        }

    SetPort(mydialog);

    LDispose(mylist);
    picklist = (ListHandle)0;
    DisposDialog(mydialog);

    return TCL_OK;
    }


static Handle        _tcl_Houtput_handle = NULL;

Handle
tcl_Houtput_sethdl(handle)
Handle    handle;
{
Handle    result = _tcl_Houtput_handle;

    _tcl_Houtput_handle = handle;
    return result;
    }

Handle
tcl_Houtput_gethdl()
{
    return _tcl_Houtput_handle;
    }

tcl_handle_output(str)
char    *str;
{
long    length;

    length = GetHandleSize(_tcl_Houtput_handle);
    SetHandleSize(_tcl_Houtput_handle, length + strlen(str));
    if (MemError() == noErr) {
        memcpy( (*_tcl_Houtput_handle + length), str, strlen(str) );
        }

    }

int
Tcl_Interp_Handle(interp, script_handle, result_handle, stdout_handle)
Tcl_Interp    *interp;
Handle        script_handle;
Handle        result_handle;
Handle        stdout_handle;
{
int        result;
PFI        saveproc;
Handle    saveH, myhandle = NULL;
char    result_str[64]/*, *save, *ptr*/;

    if (stdout_handle == NULL)
        {
        myhandle = NewHandle(0);
        if (myhandle == NULL)
            {
            Feedback("Error #%d allocating a stdout handle.", MemError());
            return -1770;
            }
        else
            saveH = tcl_Houtput_sethdl(myhandle);
        }
    else
        saveH = tcl_Houtput_sethdl(stdout_handle);

    saveproc = Tcl_SetPrintProcedure(tcl_handle_output);

    HLock(script_handle);

    result = Tcl_RecordAndEval(interp, *script_handle, 0);

#ifdef NEVER_DEFINED
    ptr = save = *script_handle;
    for ( ; *ptr ; )
        {
        int        savech;

        for ( ; *ptr && *ptr != '\n' ; ptr++)
            ;
        savech = *ptr;
        *ptr = '\0';

        result = Tcl_RecordAndEval(interp, save, 0);
        if (result != TCL_OK)
            break;

        if (savech == '\0')
            break;

        *ptr++ = savech;
        save = ptr;
        }
#endif

    HUnlock(script_handle);

    if (result != TCL_OK) {
        sprintf(result_str, "\015# Result = %d.\015", result);
        tcl_handle_output(result_str);
        tcl_handle_output("# ");
        tcl_handle_output(interp->result);
        }
    else if (interp->result[0] != '\0' && result_handle != NULL)
        {
        tcl_Houtput_sethdl(result_handle);
        tcl_handle_output(interp->result);
        }

    Tcl_SetPrintProcedure(saveproc);
    tcl_Houtput_sethdl(saveH);

    if (myhandle != NULL)
        DisposHandle(myhandle);

    return result;
    }


compute_path_dirid(path)
char    *path;
    {
    char        *ptr, *eptr;
    int            myerr, need_move = 0, need_rename = 0, got_end = 0;
    char        pascal_name[256];
    short        vrefnum;
    long        dirid;
    CInfoPBRec        cpb;
    ParamBlockRec    pb;

    dirid = current_dirid();
    vrefnum = current_vrefnum();

    ptr = path;

    eptr = strchr(ptr, ':');
    if (eptr != NULL && *ptr != ':') {    /* Full Path Name */
        dirid = 2;
        strncpy(&pascal_name[1], ptr, (eptr - ptr) + 1);
        pascal_name[0] = (int) ((eptr - ptr) + 1);

        pb.volumeParam.ioCompletion = 0;
        pb.volumeParam.ioNamePtr = (unsigned char *) pascal_name;
        pb.volumeParam.ioVRefNum = 0;
        pb.volumeParam.ioVolIndex = -1;
        myerr = PBGetVInfo(&pb, FALSE);
        if (myerr == noErr)
            vrefnum = pb.volumeParam.ioVRefNum;
        ptr = eptr + 1;
        }
    else if (*ptr == ':')
        ptr++;

    cpb.hFileInfo.ioCompletion = 0;
    cpb.hFileInfo.ioNamePtr = (unsigned char *) pascal_name;
    cpb.hFileInfo.ioVRefNum = vrefnum;
    cpb.hFileInfo.ioFDirIndex = 0;
    cpb.hFileInfo.ioDirID = dirid;
    for ( ; *ptr ; )
        {
        eptr = strchr(ptr, ':');
        if (eptr != NULL)
            {
            strncpy(&pascal_name[1], ptr, (eptr - ptr));
            pascal_name[0] = (int) (eptr - ptr);
            }
        else
            {
            break;
            }
        myerr = PBGetCatInfo(&cpb, FALSE);
        Feedback("compute_path_dirid: GetCat()=%d '%.*s' dirid %ld -> %ld, vRef %d ",
                    myerr, pascal_name[0], &pascal_name[1], dirid, cpb.hFileInfo.ioDirID, vrefnum);
        if (myerr != noErr)
            break;
        dirid = cpb.hFileInfo.ioDirID;
        ptr = eptr + 1;
        }

    return dirid;
    }

compute_path_vrefnum(path)
char    *path;
    {
    int                myerr;
    char            *ptr, volname[64];
    ParamBlockRec    pb;

    ptr = strchr(path, ':');
    if (ptr == NULL)
        return current_vrefnum();

    strncpy(&volname[1], path, (ptr - path) + 1);
    volname[0] = (ptr - path) + 1;

    pb.volumeParam.ioCompletion = 0;
    pb.volumeParam.ioNamePtr = (unsigned char *) volname;
    pb.volumeParam.ioVRefNum = 0;
    pb.volumeParam.ioVolIndex = -1;
    myerr = PBGetVInfo(&pb, FALSE);
    if (myerr == noErr)
        return pb.volumeParam.ioVRefNum;

    return current_vrefnum();
    }

int
Cmd_ReMoveFile(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
int            myerr;
short        vrefnum;
long        dirid;
char        *ptr1, savech, *namep;
char        pascal_name[64];
HParamBlockRec    pb;
#pragma unused (clientData)

    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                            " fileName\"", (char *) NULL);
        return TCL_ERROR;
        }

    namep = argv[1];
    dirid = current_dirid();
    vrefnum = current_vrefnum();
    ptr1 = strrchr(namep, ':');

    if (ptr1 != NULL) {
        savech = *(ptr1+1);
        *(ptr1+1) = '\0';
        dirid = compute_path_dirid(namep);
        *(ptr1+1) = savech;
        strcpy(pascal_name, ptr1 + 1);
        vrefnum = compute_path_vrefnum(namep);
        }
    else
        strcpy(pascal_name, namep);

    c2pstr(pascal_name);
    pb.fileParam.ioCompletion = 0;
    pb.fileParam.ioNamePtr = (unsigned char *) pascal_name;
    pb.fileParam.ioVRefNum = vrefnum;
    pb.fileParam.ioDirID = dirid;
    myerr = PBHDelete(&pb, FALSE);
    if (myerr != noErr)
        {
        macintoshErr = myerr;
        Tcl_AppendResult(interp, "\"", argv[0], "\" ", "error deleting \"",
                        argv[1], "\" ", Tcl_MacError(interp), (char *) NULL);
        return TCL_ERROR;
        }

    return TCL_OK;
    }

int
Cmd_MoveFile(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
int            myerr, need_move = 0, need_rename = 0, force = 0;
short        from_vrefnum;
long        from_dirid, to_dirid;
char        *ptr1, *ptr2, savech, *oldname, *newname;
char        pascal_name[64], from_name[64], to_name[64];
HParamBlockRec    pb;
CMovePBRec        mpb;
#pragma unused (clientData)

    if (argc < 3 || argc > 4) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " oldName newName ?force?\"", (char *) NULL);
        return TCL_ERROR;
        }

    if (argc == 4)
        {
        if (strcmp(argv[3], "force")) {
            Tcl_AppendResult(interp, "wrong parameter \"", argv[3], "\" : should be \"", argv[0],
                " oldName newName ?force?\"", (char *) NULL);
            return TCL_ERROR;
            }

        force = 1;
        }

    oldname = argv[1];
    newname = argv[2];

    to_dirid = current_dirid();
    from_dirid = current_dirid();

    from_vrefnum = current_vrefnum();

    ptr1 = strrchr(oldname, ':');
    ptr2 = strrchr(newname, ':');

    if (ptr1 != NULL) {
        savech = *(ptr1+1);
        *(ptr1+1) = '\0';
        from_dirid = compute_path_dirid(oldname);
        *(ptr1+1) = savech;
        strcpy(from_name, ptr1 + 1);
        from_vrefnum = compute_path_vrefnum(oldname);
        }
    else
        strcpy(from_name, oldname);

    if (ptr2 != NULL) {
        savech = *(ptr2+1);
        *(ptr2+1) = '\0';
        to_dirid = compute_path_dirid(newname);
        *(ptr2+1) = savech;
        strcpy(to_name, ptr2 + 1);
        from_vrefnum = compute_path_vrefnum(newname);
        }
    else
        strcpy(to_name, newname);

    if (ptr1 != NULL || ptr2 != NULL)
        {
        need_move = 1;
        if (ptr1 != NULL && ptr2 != NULL) {
            *ptr1 = '\0';
            *ptr2 = '\0';
            if (strcmp(oldname, newname) == 0)
                need_move = 0;
            *ptr1 = ':';
            *ptr2 = ':';
            }
        }

    if (strcmp(from_name, to_name) != 0)
        need_rename = 1;

    if (need_move)
        {
        strcpy(pascal_name, from_name);
        c2pstr(pascal_name);

retry_move:
        mpb.ioCompletion = 0;
        mpb.ioNamePtr = (unsigned char *) pascal_name;
        mpb.ioVRefNum = from_vrefnum;
        mpb.ioNewName = "\p";
        mpb.ioNewDirID = to_dirid;
        mpb.ioDirID = from_dirid;
        myerr = PBCatMove(&mpb, FALSE);
        if (myerr != noErr)
            {
            if (force && myerr == dupFNErr)
                {
                pb.fileParam.ioCompletion = 0;
                pb.fileParam.ioNamePtr = (unsigned char *) pascal_name;
                pb.fileParam.ioVRefNum = from_vrefnum;
                pb.fileParam.ioFVersNum = 0;
                pb.fileParam.ioDirID = to_dirid;
                myerr = PBHDelete(&pb, FALSE);
                if (myerr == noErr)
                    goto retry_move;
                }

            macintoshErr = myerr;
            Tcl_AppendResult(interp, "\"", argv[0], "\" error moving file ",
                                Tcl_MacError(interp), (char *) NULL);
            return TCL_ERROR;
            }
        }

    if (need_rename)
        {
        c2pstr(from_name);
        c2pstr(to_name);

retry_rename:
        pb.ioParam.ioCompletion = 0;
        pb.ioParam.ioNamePtr = (unsigned char *) from_name;
        pb.ioParam.ioVRefNum = from_vrefnum;
        pb.ioParam.ioMisc = to_name;
        pb.ioParam.ioVersNum = 0;
        pb.fileParam.ioDirID = to_dirid;
        myerr = PBHRename(&pb, FALSE);
        if (myerr != noErr)
            {
            if (force && myerr == dupFNErr)
                {
                pb.fileParam.ioCompletion = 0;
                pb.fileParam.ioNamePtr = (unsigned char *) to_name;
                pb.fileParam.ioVRefNum = from_vrefnum;
                pb.fileParam.ioFVersNum = 0;
                pb.fileParam.ioDirID = to_dirid;
                myerr = PBHDelete(&pb, FALSE);
                if (myerr == noErr)
                    goto retry_rename;
                }
            macintoshErr = myerr;
            Tcl_AppendResult(interp, "\"", argv[0], "\" error renaming file ",
                                Tcl_MacError(interp), (char *) NULL);
            return TCL_ERROR;
            }
        }

    return TCL_OK;
    }

int
Cmd_CopyFile(clientData, interp, argc, argv)
char        *clientData;
Tcl_Interp    *interp;
int            argc;
char        **argv;
{
int            myerr, eoferr, need_move = 0, need_rename = 0, force = 0;
short        from_vrefnum, to_vrefnum, inerr, outerr;
long        from_dirid, to_dirid;
char        *ptr1, *ptr2, savech, *oldname, *newname;
char        from_name[64], to_name[64];
HParamBlockRec    inparm, outparm;
#pragma unused (clientData)

    if (argc < 3 || argc > 4) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " fromName toName ?force?\"", (char *) NULL);
        return TCL_ERROR;
        }

    if (argc == 4)
        {
        if (strcmp(argv[3], "force")) {
            Tcl_AppendResult(interp, "wrong parameter \"", argv[3], "\" : should be \"", argv[0],
                " oldName newName ?force?\"", (char *) NULL);
            return TCL_ERROR;
            }

        force = 1;
        }

    oldname = argv[1];
    newname = argv[2];

    to_dirid = current_dirid();
    from_dirid = current_dirid();

    to_vrefnum = current_vrefnum();
    from_vrefnum = current_vrefnum();

    ptr1 = strrchr(oldname, ':');
    ptr2 = strrchr(newname, ':');

    if (ptr1 != NULL) {
        savech = *(ptr1+1);
        *(ptr1+1) = '\0';
        from_dirid = compute_path_dirid(oldname);
        *(ptr1+1) = savech;
        strcpy(from_name, ptr1 + 1);
        from_vrefnum = compute_path_vrefnum(oldname);
        }
    else
        strcpy(from_name, oldname);

    if (ptr2 != NULL) {
        savech = *(ptr2+1);
        *(ptr2+1) = '\0';
        to_dirid = compute_path_dirid(newname);
        *(ptr2+1) = savech;
        strcpy(to_name, ptr2 + 1);
        to_vrefnum = compute_path_vrefnum(newname);
        }
    else
        strcpy(to_name, newname);

    c2pstr(from_name);
    c2pstr(to_name);

    inparm.ioParam.ioCompletion = 0;
    inparm.ioParam.ioNamePtr = (unsigned char *) from_name;
    inparm.ioParam.ioVRefNum = from_vrefnum;
    inparm.ioParam.ioVersNum = 0;
    inparm.ioParam.ioPermssn = fsRdPerm;
    inparm.ioParam.ioMisc = NULL;
    inparm.fileParam.ioDirID = from_dirid;
    inerr = PBHOpen(&inparm, FALSE);
    if (inerr != noErr) {
        Feedback("DATA OPEN IN: err %d '%.*s' dir %ld vref %d ",
                    inerr, from_name[0], &from_name[1], from_dirid, from_vrefnum);
        macintoshErr = inerr;
        p2cstr(from_name);
        Tcl_AppendResult(interp, "error opening DATA \"",
                            from_name, "\" ", Tcl_MacError(interp), (char *) NULL);
        return TCL_ERROR;
        }

    outparm.ioParam.ioCompletion = 0;
    outparm.ioParam.ioNamePtr = (unsigned char *) to_name;
    outparm.ioParam.ioVRefNum = to_vrefnum;
    outparm.ioParam.ioVersNum = 0;
    outparm.ioParam.ioPermssn = fsWrPerm;
    outparm.ioParam.ioMisc = NULL;
    outparm.fileParam.ioDirID = to_dirid;
    outerr = PBHCreate(&outparm, false);
    if ( (outerr != noErr && outerr != dupFNErr) ||
         (outerr == dupFNErr && ! force) )
        {
        Feedback("DATA CREATE: err %d '%.*s' dir %ld vref %d ",
                    outerr, to_name[0], &to_name[1], to_dirid, to_vrefnum);
        PBClose((ParmBlkPtr)&inparm, false);
        p2cstr(to_name);
        macintoshErr = outerr;
        Tcl_AppendResult(interp, "error creating DATA \"",
                            to_name, "\" ", Tcl_MacError(interp), (char *) NULL);
        return TCL_ERROR;
        }

    outerr = PBHOpen(&outparm, false);
    if (outerr != noErr) {
        Feedback("DATA OPEN: err %d '%.*s' dir %ld vref %d ",
                    outerr, to_name[0], &to_name[1], to_dirid, to_vrefnum);
        PBClose((ParmBlkPtr)&inparm, false);
        p2cstr(to_name);
        macintoshErr = outerr;
        Tcl_AppendResult(interp, "error opening DATA \"",
                            to_name, "\" ", Tcl_MacError(interp), (char *) NULL);
        return TCL_ERROR;
        }

    myerr = CopyFork(&inparm, &outparm);

    PBGetEOF((ParmBlkPtr)&inparm, FALSE);
    outparm.ioParam.ioMisc = inparm.ioParam.ioMisc;
    eoferr = PBSetEOF((ParmBlkPtr)&outparm, FALSE);

    PBClose((ParmBlkPtr)&inparm, FALSE);
    PBClose((ParmBlkPtr)&outparm, FALSE);

    FlushVol(NULL, to_vrefnum);

    if (myerr != noErr) {
        p2cstr(to_name);
        p2cstr(from_name);
        Tcl_AppendResult(interp, "error copying DATA \"",
                            from_name, "\" to \"", to_name, "\" ", (char *) NULL);
        return TCL_ERROR;
        }

    if (eoferr != noErr) {
        macintoshErr = myerr;
        Tcl_AppendResult(interp, "error setting DATA EOF ", Tcl_MacError(interp), (char *) NULL);
        return TCL_ERROR;
        }

    myerr = PBHOpenRF(&inparm, FALSE);
    if (myerr != noErr && myerr != eofErr && myerr != fnfErr) {
        Feedback("RSRC OPEN IN: err %d '%.*s' dir %ld vref %d ",
                    myerr, from_name[0], &from_name[1], from_dirid, from_vrefnum);
        macintoshErr = myerr;
        p2cstr(from_name);
        Tcl_AppendResult(interp, "error opening RSRC \"",
                            from_name, "\" ", Tcl_MacError(interp), (char *) NULL);
        return TCL_ERROR;
        }
    else if (myerr == noErr) {
        myerr = PBHOpenRF(&outparm, false);
        if (myerr != noErr) {
            Feedback("RSRC OPEN OUT: err %d '%.*s' dir %ld vref %d ",
                        myerr, to_name[0], &to_name[1], to_dirid, to_vrefnum);
            PBClose((ParmBlkPtr)&inparm, FALSE);
            macintoshErr = myerr;
            p2cstr(from_name);
            Tcl_AppendResult(interp, "error opening RSRC \"",
                                to_name, "\" ", Tcl_MacError(interp), (char *) NULL);
            return TCL_ERROR;
            }

        myerr = CopyFork(&inparm, &outparm);

        PBGetEOF((ParmBlkPtr)&inparm, FALSE);
        outparm.ioParam.ioMisc = inparm.ioParam.ioMisc;
        eoferr = PBSetEOF((ParmBlkPtr)&outparm, FALSE);

        PBClose((ParmBlkPtr)&inparm, FALSE);
        PBClose((ParmBlkPtr)&outparm, FALSE);

        if (myerr != noErr) {
            p2cstr(to_name);
            p2cstr(from_name);
            Tcl_AppendResult(interp, "error copying RSRC \"",
                                from_name, "\" to \"", to_name, "\" ", (char *) NULL);
            return TCL_ERROR;
            }
        if (eoferr != noErr) {
            macintoshErr = myerr;
            Tcl_AppendResult(interp, "error setting RSRC EOF ", Tcl_MacError(interp), (char *) NULL);
            return TCL_ERROR;
            }
        }

    FlushVol(NULL, to_vrefnum);

    inparm.fileParam.ioCompletion = 0;
    inparm.fileParam.ioNamePtr = (unsigned char *) from_name;
    inparm.fileParam.ioVRefNum = from_vrefnum;
    inparm.fileParam.ioFVersNum = 0;
    inparm.fileParam.ioDirID = from_dirid;
    inparm.fileParam.ioFDirIndex = 0;
    myerr = PBHGetFInfo(&inparm, FALSE);
    if (myerr == noErr)
        {
        outparm.fileParam.ioCompletion = 0;
        outparm.fileParam.ioNamePtr = (unsigned char *) to_name;
        outparm.fileParam.ioVRefNum = to_vrefnum;
        outparm.fileParam.ioFVersNum = 0;
        outparm.fileParam.ioDirID = to_dirid;
        outparm.fileParam.ioFDirIndex = 0;
        outparm.fileParam.ioFlFndrInfo = inparm.fileParam.ioFlFndrInfo;
        outparm.fileParam.ioFlFndrInfo.fdLocation.h += 16;
        outparm.fileParam.ioFlFndrInfo.fdLocation.v += 16;
        GetDateTime(&outparm.fileParam.ioFlCrDat);
        outparm.fileParam.ioFlMdDat = outparm.fileParam.ioFlCrDat;
        myerr = PBHSetFInfo(&outparm, FALSE);
        if (myerr != noErr) {
            Feedback("SET INFO: err %d '%.*s' dir %ld vref %d ",
                        myerr, to_name[0], &to_name[1], to_dirid, to_vrefnum);
            macintoshErr = myerr;
            Tcl_AppendResult(interp, "error setting INFO ", Tcl_MacError(interp), (char *) NULL);
            return TCL_ERROR;
            }
        }
    else
        {
        Feedback("GET INFO: err %d '%.*s' dir %ld vref %d ",
                        myerr, from_name[0], &from_name[1], from_dirid, from_vrefnum);
        macintoshErr = myerr;
        Tcl_AppendResult(interp, "error getting INFO ", Tcl_MacError(interp), (char *) NULL);
        return TCL_ERROR;
        }

    FlushVol(NULL, to_vrefnum);
    return TCL_OK;
    }

#define    INPARAM        inparm->ioParam
#define    OUTPARAM    outparm->ioParam
CopyFork(inparm, outparm)
ParamBlockRec    *inparm;
ParamBlockRec    *outparm;
{
short done, myerr;
char mybuffer[512];

    for (done=false; ! done; ) {
        inparm->ioParam.ioReqCount = (long)512;
        inparm->ioParam.ioBuffer = mybuffer;
        inparm->ioParam.ioPosMode = fsAtMark;

        myerr = PBRead(inparm, (Boolean)false);

        if (myerr != noErr && myerr != eofErr)
            return myerr;
        if (myerr == eofErr)
            done = true;

        outparm->ioParam.ioReqCount = INPARAM.ioActCount;
        outparm->ioParam.ioBuffer = mybuffer;
        outparm->ioParam.ioPosMode = fsAtMark;

        myerr = PBWrite(outparm, (Boolean)false);

        if (myerr != noErr)
            return myerr;
        if (inparm->ioParam.ioActCount != outparm->ioParam.ioActCount) {
            done = true;
            }
        }

    return noErr;
    }

typedef struct {
    char    *name;
    char    *value;
    } environ_entry;

environ_entry    *environment = NULL;
int                environ_entries = 0;
int                environ_allocated = 0;

init_environment()
{
char    *ptr;
FILE    *infile;
char    input[512];
char    filtered[512];

#ifdef NEVER_DEFINED
    check_environment_add(32);
#endif

    infile = fopen("Ñtclenv", "r");
    if (infile != NULL) {
        for ( ; fgets(input, sizeof(input)-1, infile) != NULL ; ) {
#ifdef THINK_C
            if (input[strlen(input)-1] == '\r')
                input[strlen(input)-1] = '\0';
            if (input[strlen(input)-1] == '\n')
                input[strlen(input)-1] = '\0';
#endif
            if (input[strlen(input)-1] == '\015')
                input[strlen(input)-1] = '\0';
            for (ptr=input; *ptr && *ptr != '='; ptr++)
                ;
            if (*ptr == '=') {
                *ptr = '\0';
                filter_unix_string(filtered, ptr + 1);
                tcl_setenv(input, filtered);
                *ptr = '=';
                }
            }

        fclose(infile);
        }
    }

#ifdef NEVER_DEFINED

put_environment(name, value)
char    *name;
char    *value;
{
    check_environment_add(1);

    environment[environ_entries].name = csavestr(name);
    environment[environ_entries].value = csavestr(value);
    environ_entries++;

    check_environment_set_of_globals(name, value);
    }

char *
get_environment(name)
char    *name;
{
int        i;

    for (i = 0; i < environ_entries; i++)
        if (StrCmp(environment[i].name, name) == 0)
            return environment[i].value;

    return NULL;
    }

check_environment_add(num)
int        num;
{
int                new_count;
environ_entry    *new_entries;

    if ( (environ_entries + num) >= environ_allocated )
        {
        new_count = environ_entries + num + 16;
        new_entries = (environ_entry *) malloc(new_count * sizeof(environ_entry));
        if (new_entries != NULL) {
            memset(new_entries, 0, environ_entries * sizeof(environ_entry));
            memcpy(new_entries, environment, environ_entries * sizeof(environ_entry));
            if (environment != NULL)
                free(environment);
            environment = new_entries;
            environ_allocated = new_count;
            }
        else
            return 0;
        }

    return 1;
    }

#endif

list_environment()
{
#ifdef NEVER_DEFINED
int        i;

    Feedback("Environment has %d entries. %d allocated.", environ_entries, environ_allocated);
    for (i = 0; i < environ_entries; i++)
        Feedback("<%s> <%s>", environment[i].name, environment[i].value);
#endif
    }

#ifdef NEVER_DEFINED

read_default_environment_globals()
    {
    char    *ptr;

    ptr = get_environment("LOGLEVEL");
    if (ptr != NULL)
        g_log_level = atoi(ptr);

#ifdef TCLENGINE
    ptr = get_environment("ENGINE_NOISE");
    if (ptr != NULL)
        {
        engine_verbosity = atoi(ptr);
        if (engine_verbosity < 0 || engine_verbosity > 2)
            engine_verbosity = 1;
        }
#endif
    }

#endif

check_environment_set_of_globals(name, value)
char    *name;
char    *value;
    {
    if (strcmp("CRON_TICKS", name) == 0)
        {
        g_cron_interval = atol(value);
        g_next_cron_time = TickCount() + g_cron_interval;
        Feedback("Cron ticks now: %ld. Next task time: %ld.",
                    g_cron_interval, g_next_cron_time);
        }
    else if (strcmp("TEXT_CREATOR", name) == 0)
        {
        char    tempstr[8];

        sprintf(tempstr, "%-4.4s", value);
        memcpy(&def_text_file_creator, tempstr, 4);
        Feedback("Default text creator now: '%-4.4s'.", &def_text_file_creator);
        }
    }


char *
csavestr(str)
char    *str;
{
char    *ptr;

    ptr = malloc(strlen(str) + 1);
    if (ptr)
        strcpy(ptr, str);
    return ptr;
    }

Tcl_InitMacintosh(interp)
Tcl_Interp    *interp;
{
int        result;
char    command[128];

    Tcl_CreateCommand(interp, "alertnote", Cmd_DoAlertNote,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "cd", Cmd_DoCD,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "pwd", Cmd_DoPWD,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "get_directory", Cmd_GetDirectory,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "getenv", Cmd_DoGetenv,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "putenv", Cmd_DoPutenv,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "xtclcmd", Cmd_CallExternalCMD,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "askyesno", Cmd_AskYesNoCancel,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "getline", Cmd_GetInputLine,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "espace", Cmd_EscapeSpaces,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "getfile", Cmd_GetFile,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "putfile", Cmd_PutFile,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "listpick", Cmd_MacListPick,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "feedback", Cmd_Feedback,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "getfinfo", Cmd_GetFileInfo,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "setfinfo", Cmd_SetFileInfo,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "ctime", Cmd_CTime,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "mtime", Cmd_MacDateTime,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "mv", Cmd_MoveFile,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "cp", Cmd_CopyFile,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "rm", Cmd_ReMoveFile,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "now", Cmd_Now,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "ticks", Cmd_Ticks,
                        (ClientData)NULL, (void (*)())NULL);
    Tcl_CreateCommand(interp, "yield_mac", Cmd_TclMacYield,
                        (ClientData)NULL, (void (*)())NULL);

    Tcl_InitXmath(interp);

    sprintf(command, "set HARVESTCVERS {%#s}\n", MyVersion);
    result = Tcl_Eval(interp, command, 0, (char **)0);
    if (result != TCL_OK)
        Feedback("ERROR %d on <%s>", result, command);

    sprintf(command, "set MACINTOSH 1\n");
    result = Tcl_Eval(interp, command, 0, (char **)0);
    if (result != TCL_OK)
        Feedback("ERROR %d on <%s>", result, command);

    sprintf(command, "set AEVENT 0\n");
    result = Tcl_Eval(interp, command, 0, (char **)0);
    if (result != TCL_OK)
        Feedback("ERROR %d on <%s>", result, command);

    Tcl_SetPrintProcedure(tcl_print_tclshell);
}

static char             message_string[512];

#define message_note_alert      (short)1010
#define message_alert_alert     (short)1011

message_note(format_str, arg0, arg1, arg2, arg3, arg4, arg5)
char    *format_str;
long    arg0, arg1, arg2, arg3, arg4, arg5;
{
Str255  pascal_name;
        InitCursor();
        sprintf(message_string, format_str,
                        arg0, arg1, arg2, arg3, arg4, arg5);
        pascal_name[0] = strlen(message_string);
        strcpy((char *) &pascal_name[1], message_string);
        ParamText(&pascal_name, NULL, NULL, NULL);
        NoteAlert(message_note_alert, (ModalFilterProcPtr)0);
        }

message_alert(format_str, arg0, arg1, arg2, arg3, arg4, arg5)
char    *format_str;
long    arg0, arg1, arg2, arg3, arg4, arg5;
{
Str255  pascal_name;
        InitCursor();
        sprintf(message_string, format_str,
                        arg0, arg1, arg2, arg3, arg4, arg5);
        pascal_name[0] = strlen(message_string);
        strcpy((char *) &pascal_name[1], message_string);
        ParamText(&pascal_name, NULL, NULL, NULL);
        StopAlert(message_alert_alert, (ModalFilterProcPtr)0);
        }

/*
** Copyright (c) 1988 By Tim Endres
** 8840 Main St.
** Whitmore Lake, Mi.  48189
**
** Written by Tim Endres.
*/

#define getInit         -1              /* Initialize */
#define getMenu         102             /* Folder Menu Mouse */
#define getFolder       103             /* Open Folder */
#define getUseDir       11              /* Use This Directory Button */


#define GETDIRECT_DIALOG        6767
#define GETDIRHLP_DIALOG        6765
#define prompt_item                     11
#define select_item                     12
#define help_item                       13

#define getInit                         -1              /* Initialize */
#define getStaySF                       0
#define getIdle                         100             /* Idle routine  */
#define redrawFiles                     101             /* Redraw the files in t
he list */
#define getMenu                         102             /* Folder Menu Mouse */
#define getFolder                       103             /* Open Folder */

static SFReply                          getDir_Reply;
static char                                     getDir_prompt[256];
static char                                     save_fName0;
static OSType                           save_fType;

void
show_getdir_help(parent)
DialogPtr       parent;
        {
        short           itemhit, done;
        DialogPtr       mydialog;
        GrafPtr         saveport;
        Handle          dlogrsrc;
        Rect            *rect_ptr;
        Point           mypt;

        GetPort(&saveport);

        InitCursor();
        dlogrsrc = GetResource((ResType)'DLOG', (short)GETDIRHLP_DIALOG);
        if (dlogrsrc != NULL) {
                LoadResource(dlogrsrc);
                rect_ptr = (Rect *) *dlogrsrc;
                mypt.v = parent->portRect.bottom - (8 + (rect_ptr->bottom - rect_ptr->top));
                mypt.h = parent->portRect.left + 8;
                LocalToGlobal(&mypt);
                OffsetRect(rect_ptr, (mypt.h - rect_ptr->left), (mypt.v - rect_ptr->top));
                }
        mydialog = GetNewDialog(GETDIRHLP_DIALOG, NULL, (void *) -1 /* inFront */);
        if (mydialog == NULL)
                {
                SysBeep(0);
                return;
                }

        SetPort(mydialog);
        TextFont(geneva);
        TextSize(9);

        for (done=0; ! done; )  {
                SetPort(mydialog);
                ModalDialog((ModalFilterProcPtr)0, &itemhit);
                switch (itemhit) {
                        case ok:
                                done = 1;
                                break;
                        }
                }

        DisposDialog(mydialog);
        SetPort(saveport);
        return;
        }

pascal short GetDirHook(item, dialog)
short           item;
DialogPtr       dialog;
{
int             need_check = 0;

        switch (item) {
                case getInit:
                        need_check = 0;
                        save_fName0 = getDir_Reply.fName[0];
                        save_fType  = getDir_Reply.fType;
                        MySetText(dialog, prompt_item, getDir_prompt);
                        MyHiliteControl(dialog, select_item, 255);
                        break;
                case getOpen:                           /* Open or DoubleClick w
ith selected file... */
                        item = getStaySF;
                        need_check = 1;
                        break;
                case getFolder:                         /* Open or DoubleClick w
ith selected folder... */
                        need_check = 1;
                        break;
                case select_item:
                        item = getOpen;
                        break;
                case help_item:
                        show_getdir_help(dialog);
                        item = getStaySF;
                        break;
                case getCancel:
                        break;
                case getMenu:
                case getNmList:
                case getScroll:
                        need_check = 1;
                        break;
                case getIdle:
                        break;
                default:        /* Key down's are 1000 + ASCII-code */
                        need_check = 1;
                        break;
                }

        if (! need_check)
                {
                if (save_fName0 != getDir_Reply.fName[0]
                        || save_fType != getDir_Reply.fType)
                        need_check = 1;
                }
        if (need_check)
                {
                if (getDir_Reply.fName[0] == '\0' && getDir_Reply.fType == 0)
                        {
                                /* NOTHING Selected... */
                        MyHiliteControl(dialog, select_item, 0);
                        }
                else if (getDir_Reply.fName[0] == '\0')
                        {
                                /* DIRECTORY */
                        MyHiliteControl(dialog, select_item, 0);
                        }
                else
                        {
                                /* FILE */
                        MyHiliteControl(dialog, select_item, 255);
                        /* item = getStaySF; */
                        }

                save_fName0 = getDir_Reply.fName[0];
                save_fType  = getDir_Reply.fType;
                need_check = 0;
                }

        return item;
        }

pascal Boolean NoFiles(pb)
FileParam *pb;
{
#pragma unused (pb)

        return false;
        }

GetFolderPathName(prompt, path_name, volref, dirid)
char    *prompt;
char    *path_name;
short   *volref;
long    *dirid;
{
SFTypeList              mytypes;
Point                   mypoint;
int                             len;
WindowPtr               myWindow;

        strcpy(getDir_prompt, prompt);

        myWindow = FrontWindow();

        /* gdhfp = (FILE *)0; */

        mypoint.h = mypoint.v = 75;
        SFPGetFile(mypoint, "\p", NoFiles, -1, mytypes, GetDirHook,
                                        &getDir_Reply, GETDIRECT_DIALOG, (ModalFilterProcPtr)0);
        if (getDir_Reply.good) {

                if (getDir_Reply.fName[0] != '\0') {
                        *volref = WDVolRef(getDir_Reply.vRefNum);
                        *dirid = WDDirID(getDir_Reply.vRefNum);
                        pathname(path_name, getDir_Reply.vRefNum);
                        }
                else {
                        dirpathname(path_name, getDir_Reply.vRefNum, getDir_Reply.fType);
                        *volref = getDir_Reply.vRefNum;
                        *dirid = getDir_Reply.fType;
                        }

                len = strlen(path_name);
                if (path_name[len - 1] == ':')
                        path_name[len - 1] = '\0';      /* Drop Colon */

                return 1;
                }
        else
                return 0;
        }


#define getInit                 -1              /* Initialize */
#define d_sfgetfile_id  777
#define getPromptItem   11

static  char    get_prompt[256];

pascal short PromptHook(item, dialog)
short           item;
DialogPtr       dialog;
{
        switch (item) {
                case getInit:
                        MySetText(dialog, getPromptItem, get_prompt);
                        get_prompt[0] = '\0';
                        break;
                }
        return item;
        }


MyPutFile(where, prompt, orig, hook, reply)
Point   where;
char    *prompt;
char    *orig;
DlgHookProcPtr  hook;
SFReply *reply;
{
        SFPutFile(where, prompt, orig, hook, reply);
        }

MyGetFile(sfpoint, sfprompt, sffilter, sfnumtypes, sftypes, sfhook, sfreply)
Point           sfpoint;
char            *sfprompt;
FileFilterProcPtr       sffilter;
int                     sfnumtypes;
SFTypeList      sftypes;
char            *sfhook;
SFReply         *sfreply;
{
#pragma unused (sfhook)

        strncpy(get_prompt, &sfprompt[1], sfprompt[0]);
        get_prompt[sfprompt[0]] = '\0';

        SFPGetFile(sfpoint, "\p", sffilter, sfnumtypes,
                                sftypes, PromptHook, sfreply, d_sfgetfile_id,
                                (ModalFilterProcPtr)0);
        }

/* My hacks */

#ifdef Undefined
int
pathname(char *path, int wd)
{
    GetPathNameFromWD(path,NULL,wd);
    p2cstr(path);
}

int
fullname(char *path, int wd, char *name)
{
    GetPathNameFromWD(path,name,wd);
    p2cstr(path);
}
#endif

filter_unix_string(into, from)
char    *into;
char    *from;
{
char    *ptr;

    ptr = into;
    for ( ; *from ; ) {
        if (*from == '\\') {
            switch (*(from + 1)) {
                case '\\':
                    *ptr++ = '\\'; from += 2;
                    break;
                case 'r':
                    *ptr++ = '\015'; from += 2;
                    break;
                case 'n':
                    *ptr++ = '\012'; from += 2;
                    break;
                case 't':
                    *ptr++ = '\011'; from += 2;
                    break;
                default:
                    if (isdigit(*(from+1)) &&
                        isdigit(*(from+2)) &&
                        isdigit(*(from+3)))
                        {
                        *ptr = ((*(from+1) - '0') * 64) +
                                ((*(from+2) - '0') * 8) +
                                (*(from+3) - '0');
                        ptr++; from += 4;
                        }
                    else {
                        *ptr++ = *from++;
                        }
                    break;
                }
            }
        else
            *ptr++ = *from++;
        }

    *ptr = '\0';

    return (int)(ptr - into);
    }

CheckOption()
{
KeyMap    mykeys;

    GetKeys(mykeys);
    return (mykeys[1] & 0x00000004) != 0;
    }

#define TSigWord        0x4244

char    *prepstr();

char    *
fullname(name, vrefnum, filename)
char            *name;
int                     vrefnum;
char            *filename;
{
char                    volname[32];
HVolumeParam    pb;

        strcpy(name, filename);

        pb.ioVRefNum = vrefnum;
        pb.ioNamePtr = (unsigned char *) volname; volname[0] = '\0';
        pb.ioVolIndex = 0;
        PBHGetVInfo((HParmBlkPtr)&pb, FALSE);   /* Works with 64K ROMs as well.
*/
        p2cstr(volname);
        if (pb.ioVSigWord == 0x4244)
                _prep_hfs_name(name, vrefnum);
        else
                prepstr(name, volname);
        return name;
        }

char    *
pathname(pathname, vrefnum)
char            *pathname;
int                     vrefnum;
{
char                    volname[32];
HVolumeParam    pb;

        pathname[0] = '\0';

        pb.ioVRefNum = vrefnum;
        pb.ioNamePtr = (unsigned char *) volname; volname[0] = '\0';
        pb.ioVolIndex = 0;
        PBHGetVInfo((HParmBlkPtr)&pb, FALSE);   /* Works with 64K ROMs as well.
*/
        p2cstr(volname);
        if (pb.ioVSigWord == 0x4244)
                _prep_hfs_name(pathname, vrefnum);
        else
                prepstr(pathname, volname);
        return pathname;
        }

_prep_hfs_name(fullname, vrefnum)
char    *fullname;
int             vrefnum;
{
CInfoPBRec      cpb;
WDPBRec         wpb;
char            myname[256];

        wpb.ioNamePtr = (unsigned char *) myname; myname[0] = '\0';
        wpb.ioVRefNum = vrefnum;
        wpb.ioWDIndex = 0;
        wpb.ioWDProcID = (long) 0;
        PBGetWDInfo(&wpb, FALSE);

        cpb.dirInfo.ioVRefNum = vrefnum;
        cpb.dirInfo.ioNamePtr = (unsigned char *) myname; myname[0] = '\0';
        cpb.dirInfo.ioDrDirID = wpb.ioWDDirID;
        cpb.dirInfo.ioFDirIndex = -1;
        PBGetCatInfo(&cpb, FALSE);
        p2cstr(myname);
        prepstr(fullname, myname);

        while (cpb.dirInfo.ioDrDirID != 2) {
                cpb.dirInfo.ioDrDirID = cpb.dirInfo.ioDrParID;
                cpb.dirInfo.ioNamePtr = (unsigned char *) myname; myname[0] = '\0';
                cpb.dirInfo.ioFDirIndex = -1;
                PBGetCatInfo(&cpb, FALSE);
                p2cstr(myname);
                prepstr(fullname, myname);
                }
        }

char    *
dirpathname(pathname, vrefnum, dirid)
char            *pathname;
int                     vrefnum;
long            dirid;
{
char                    volname[32];
HVolumeParam    pb;

        pathname[0] = '\0';

        pb.ioVRefNum = vrefnum;
        pb.ioNamePtr = (unsigned char *) volname; volname[0] = '\0';
        pb.ioVolIndex = 0;
        PBHGetVInfo((HParmBlkPtr)&pb, FALSE);
        p2cstr(volname);
        if (pb.ioVSigWord == 0x4244)
                _dir_prep_hfs_name(pathname, vrefnum, dirid);
        else
                prepstr(pathname, volname);
        return pathname;
        }

_dir_prep_hfs_name(fullname, vrefnum, dirid)
char    *fullname;
int             vrefnum;
long    dirid;
{
CInfoPBRec      cpb;
char            myname[256];

        cpb.dirInfo.ioVRefNum = vrefnum;
        cpb.dirInfo.ioNamePtr = (unsigned char *) myname; myname[0] = '\0';
        cpb.dirInfo.ioDrDirID = dirid;
        cpb.dirInfo.ioFDirIndex = -1;
        PBGetCatInfo(&cpb, FALSE);
        p2cstr(myname);
        prepstr(fullname, myname);

        while (cpb.dirInfo.ioDrDirID != 2) {
                cpb.dirInfo.ioDrDirID = cpb.dirInfo.ioDrParID;
                cpb.dirInfo.ioNamePtr = (unsigned char *) myname; myname[0] = '\0';
                cpb.dirInfo.ioFDirIndex = -1;
                PBGetCatInfo(&cpb, FALSE);
                p2cstr(myname);
                prepstr(fullname, myname);
                }
        }

char    *
prepstr(s1, s2)
char            *s1, *s2;
{
register char   *ptr1, *ptr2;
char                    tempstr[256];

        ptr1 = tempstr;
        ptr2 = s2;
        while (*ptr1++ = *ptr2++) ;
        ptr1--; *ptr1++ = ':';
        ptr2 = s1;
        while (*ptr1++ = *ptr2++) ;
        ptr1 = tempstr; ptr2 = s1;
        while (*ptr2++ = *ptr1++) ;
        return s1;
        }

/* I provided the following routine since it was missing from Tim Endres' code,
and it seemed an easy one.  If it's wrong, it's my fault - Eric. */

int MissedAnyParameters(AppleEvent *theEvent)
{
   DescType returnedType;
   Size     actualSize;
   OSErr    err;

   err = AEGetAttributePtr ( theEvent, keyMissedKeywordAttr,
                        typeWildCard, &returnedType, NULL, 0,
                        &actualSize);

   return err != errAEDescNotFound;
}

/* The following routine handles the misc dosc event which your application
should support.  How you integrate it into your app depends largely on the
structure of said app.  I have installed it by adding a DoAppleEvent method
to my application subclass which checks each AppleEvent to see if it is
'misc' 'dosc'.  If so, this routine is called. CUSTOM */

pascal OSErr
AEDoScriptHandler(AppleEvent *message,AppleEvent *reply,long refnum)
{
int                     result = noErr, myerr, tcl_result = TCL_OK;
char            error_str[128];
AEDesc          theDesc;
FSSpec          theFSS;
long            length;
Handle          result_handle, stdout_handle;
DescType        ignoredType;
Size            ignoredSize;
extern int      tcl_feedback_output();
#pragma unused (reply, refnum)

        result_handle = NewHandle(0);
        stdout_handle = NewHandle(0);
        if (result_handle != NULL && stdout_handle != NULL) {
                myerr = AEGetParamDesc(message, keyDirectObject, typeWildCard, & theDesc);
                if (myerr != noErr) {
                        sprintf(error_str, "GetParamDesc error %d in Do Script", myerr);
                        Feedback("%s", error_str);
                        myerr = AEPutParamPtr(reply, keyErrorString, typeChar,
                                                                        error_str, strlen(error_str));
                        result = myerr;
                        }
                else if (! MissedAnyParameters(message)) {
                        /* Got all the parameters we need. Now, go through the direct object, */
                        /* see what type it is, and parse it up. */
                        if (theDesc.descriptorType == (DescType)'TEXT')
                                {
                                length = GetHandleSize(theDesc.dataHandle);
                                SetHandleSize(theDesc.dataHandle, length + 1);
                                if (MemError() == noErr) {
                                        * (*theDesc.dataHandle + length) = '\0';

                                        tcl_result = run_DoScript(theDesc.dataHandle, result_handle, stdout_handle);

                                        length = GetHandleSize(result_handle);
                                        HLock(result_handle);
                                        myerr = AEPutParamPtr( reply, keyDirectObject,

        typeChar, *result_handle, length );
                                        HUnlock(result_handle);

                                        length = GetHandleSize(stdout_handle);
                                        HLock(stdout_handle);
                                        myerr = AEPutParamPtr(  reply,

        (tcl_result==TCL_OK ? keyStdOutObject : keyErrorString),

        typeChar, *stdout_handle, length );
                                        HUnlock(stdout_handle);

                                        result = (tcl_result == TCL_OK ? noErr : -1769);
                                        }
                                else
                                        {
                                        result = MemError();
                                        sprintf(error_str, "Error %d adding terminating zero in AEDoScript.", result);
                                        Feedback("%s", error_str);
                                        myerr = AEPutParamPtr(reply, keyErrorString, typeChar,

        error_str, strlen(error_str));
                                        }
                                }
                        else if (theDesc.descriptorType == (DescType)'alis')
                                {
                                myerr = AEGetParamPtr(  message,
                                keyDirectObject, typeFSS, &ignoredType,
                                (Ptr)&theFSS, sizeof(theFSS), &ignoredSize
                                );
                                if (myerr == noErr)
                                        {
                                        Feedback("AEDoScriptHandler: Execute script file '%.*s'.",
                                                                        theFSS.name[0], &theFSS.name[1]);

                                        tcl_result = run_AE_tcl_script(&theFSS,result_handle, stdout_handle);

                                        Feedback("AEDoScriptHandler: tcl_result= %d. Result len = %d StdOut len = %d.",
                                                        tcl_result, GetHandleSize(result_handle), GetHandleSize(stdout_handle));

                                        length = GetHandleSize(result_handle);
                                        HLock(result_handle);
                                        myerr = AEPutParamPtr( reply, keyDirectObject,

        typeChar, *result_handle, length );
                                        HUnlock(result_handle);

                                        length = GetHandleSize(stdout_handle);
                                        HLock(stdout_handle);
                                        myerr = AEPutParamPtr(  reply,

        (tcl_result==TCL_OK ? keyStdOutObject : keyErrorString),

        typeChar, *stdout_handle, length );
                                        HUnlock(stdout_handle);

                                        result = (tcl_result == TCL_OK ? noErr : -1769);
                                        }
                                else
                                        {
                                        sprintf(error_str, "AEDoScriptHandler: Error #%d AEGetParamPtr(typeFSS).", myerr);
                                        Feedback("%s", error_str);
                                        myerr = AEPutParamPtr(reply, keyErrorString, typeChar,

        error_str, strlen(error_str));
                                        result = myerr;
                                        }
                                }
                        else
                                {
                                sprintf(error_str, "invalid script type '%-4.4s', must be 'alis' or 'TEXT'",
                                                        &theDesc.descriptorType);
                                Feedback("%s", error_str);
                                myerr = AEPutParamPtr(reply, keyErrorString, typeChar,
error_str, strlen(error_str));
                                result = -1770;
                                }

                        }
                else
                        {
                        sprintf(error_str, "AEDoScriptHandler: MissedAnyParameters!!!");
                        Feedback("%s", error_str);
                        myerr = AEPutParamPtr(reply, keyErrorString, typeChar,
                                                                        error_str, strlen(error_str));
                        result = -1771;
                        }

                if (myerr = AEDisposeDesc(&theDesc))
                        Feedback("Error %d AEDisposeDesc in Do Script.", myerr);

                }
        else
                {
                sprintf(error_str, "Error %d allocating result handle in AEDoScript.", result);
                Feedback("%s", error_str);
                myerr = AEPutParamPtr(reply, keyErrorString, typeChar,
                                                                error_str, strlen(error_str));
                result = MemError();
                }

        if (result_handle != NULL)
                DisposHandle(result_handle);
        if (stdout_handle != NULL)
                DisposHandle(stdout_handle);

        return result;
        }

int WDDirID(short vRefNum)
{

    WDPBRec    myBlock;

    /*
    /* PBGetWDInfo has a bug under A/UX 1.1.  If vRefNum is a real vRefNum
    /* and not a wdRefNum, then it returns garbage.  Since A/UX has only 1
    /* volume (in the Macintosh sense) and only 1 root directory, this can
    /* occur only when a file has been selected in the root directory (/).
    /* So we look for this and hardcode the DirID and vRefNum. */

    myBlock.ioNamePtr = NULL;
    myBlock.ioVRefNum = vRefNum;
    myBlock.ioWDIndex = 0;
    myBlock.ioWDProcID = 0;

    /* Change the Working Directory number in vRefnum into a real vRefnum */
    /* and DirID. The real vRefnum is returned in ioVRefnum, and the real */
    /* DirID is returned in ioWDDirID. */

    PBGetWDInfo(&myBlock,false);

    return myBlock.ioWDDirID;
}

int WDVolRef(short vRefNum)
{

    WDPBRec    myBlock;

    /*
    /* PBGetWDInfo has a bug under A/UX 1.1.  If vRefNum is a real vRefNum
    /* and not a wdRefNum, then it returns garbage.  Since A/UX has only 1
    /* volume (in the Macintosh sense) and only 1 root directory, this can
    /* occur only when a file has been selected in the root directory (/).
    /* So we look for this and hardcode the DirID and vRefNum. */

    myBlock.ioNamePtr = NULL;
    myBlock.ioVRefNum = vRefNum;
    myBlock.ioWDIndex = 0;
    myBlock.ioWDProcID = 0;

    /* Change the Working Directory number in vRefnum into a real vRefnum */
    /* and DirID. The real vRefnum is returned in ioVRefnum, and the real */
    /* DirID is returned in ioWDDirID. */

    PBGetWDInfo(&myBlock,false);

    return myBlock.ioWDVRefNum;
}

void RotateCursor(int x) {
    gApplication->SpinCursor();    /* CUSTOM */
}